92 lines
4.0 KiB
Mathematica
92 lines
4.0 KiB
Mathematica
PSJMEDS ;BIR/MV-FIND PATIENT INFO FOR SPECIFIC WARD ;07 Jul 98 / 4:05 PM
|
|
;;5.0; INPATIENT MEDICATIONS ;**34,111**;16 DEC 97
|
|
;
|
|
; Reference to ^PS(51.2 is supported by DBIA #2178
|
|
; Reference to ^PS(55 is supported by DBIA# 2191
|
|
;
|
|
WARDGP ;*** Find wards within a ward group
|
|
S PSGWD="",TM="ZZ" F S PSGWD=$O(^PS(57.5,"AC",PSGWG,PSGWD)) Q:'PSGWD I $D(^DIC(42,+PSGWD,0)) S PSGWN=$P(^(0),U) D WARD
|
|
Q:PSGWG'="^OTHER"
|
|
N STDTE
|
|
S PSGSS="G",PSJACNWP=""
|
|
S STDTE=0 F S STDTE=$O(^PS(55,"AUDC",STDTE)) Q:'STDTE S CLINIC=0 F S CLINIC=$O(^PS(55,"AUDC",STDTE,CLINIC)) Q:'CLINIC D
|
|
. S JDFN=0 F S JDFN=$O(^PS(55,"AUDC",STDTE,CLINIC,JDFN)) Q:'JDFN S PSGP=JDFN D ^PSJAC S PPN=PSGP(0) D MEDTYPE
|
|
S STDTE=0 F S STDTE=$O(^PS(55,"AIVC",STDTE)) Q:'STDTE S CLINIC=0 F S CLINIC=$O(^PS(55,"AIVC",STDTE,CLINIC)) Q:'CLINIC D
|
|
. S JDFN=0 F S JDFN=$O(^PS(55,"AIVC",STDTE,CLINIC,JDFN)) Q:'JDFN S PSGP=JDFN D ^PSJAC S PPN=PSGP(0) D MEDTYPE
|
|
Q
|
|
;
|
|
WARD ;*** Go through each patient within a given WARD
|
|
;*** Var used in PSJAC. Set to null to skip WP^PSJAC
|
|
;
|
|
S PSJACNWP=""
|
|
F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGWN,PSGP)) Q:'PSGP D ^PSJAC S PPN=PSGP(0) D:PSGSS="W" TEAM D:PSGSS="G" MEDTYPE
|
|
Q
|
|
;
|
|
TEAM ;*** Look up selected team. PSGTMALL= All teams were selected.
|
|
;
|
|
S TM="ZZ"
|
|
I PSGTMALL D ALLTM,MEDTYPE Q
|
|
I 'PSGTM D MEDTYPE Q
|
|
I PSGTM,'PSGTMALL S TM="",RBNO=0 F S TM=$O(PSGTM(TM)) Q:TM="" S TMNO=PSGTM(TM) S:$G(PSJPRB) RBNO=$O(^PS(57.7,"AWRT",PSGWD,PSJPRB,TMNO,0)) D:RBNO MEDTYPE
|
|
Q
|
|
;
|
|
ALLTM ;*** Get UNIT DOSE information from ^PS(55
|
|
;
|
|
S TM=$S(PSJPRB="":0,1:+$O(^PS(57.7,"AWRT",PSGWD,PSJPRB,0))),TM=$S('$G(TM):"ZZ",'$D(^PS(57.7,PSGWD,1,TM,0)):TM,$P(^(0),U)]"":$P(^(0),U),1:TM)
|
|
Q
|
|
;
|
|
MEDTYPE ;
|
|
S:PSJPRB="" PSJPRB="NOT FOUND"
|
|
I PSGMTYPE[1 F XTYPE=2:1:6 D LOOP(XTYPE)
|
|
I PSGMTYPE'[1 F XTYPE=2:1:6 D:PSGMTYPE[XTYPE LOOP(XTYPE)
|
|
D ^PSJMPEND
|
|
Q
|
|
;
|
|
LOOP(XTYPE) ;*** Loop through stop date cross ref. to find unit dose nodes
|
|
I XTYPE=2 F PST="C","O","OC","P","R" F PSGEXPDT=PSGPLS-.0001:0 S PSGEXPDT=$O(^PS(55,PSGP,5,"AU",PST,PSGEXPDT)) Q:'PSGEXPDT D
|
|
. F ON=0:0 S ON=$O(^PS(55,PSGP,5,"AU",PST,PSGEXPDT,ON)) Q:'ON D UDOSE
|
|
I XTYPE=2 S PST="S" D ^PSJMIV
|
|
I XTYPE>2 S PST=$S(XTYPE=3:"P",XTYPE=4:"A",XTYPE=5:"H",XTYPE=6:"C") D ^PSJMIV
|
|
I XTYPE=3 S PST="S" D ^PSJMIV
|
|
Q
|
|
;
|
|
UDOSE ;
|
|
;*** Check on status for Hold,Discontinue,Expired,DE(discontinue Edit)
|
|
S UD0=$G(^PS(55,PSGP,5,ON,0)) Q:"DE"[$P(UD0,U,9)
|
|
S UD2=$G(^PS(55,PSGP,5,ON,2)) Q:$P(UD2,U,2)>PSGPLF
|
|
;
|
|
;*** Setup drug info
|
|
S DRG=$E($$ENPDN^PSGMI(+$G(^PS(55,PSGP,5,ON,.2))),1,20)_U_ON,PSJDOS=$P($G(^PS(55,PSGP,5,ON,.2)),U,2)
|
|
I $P($G(^PS(51.2,+$P(UD0,U,3),0)),U)]"" S PSJMR=$E($S($P(^(0),U,3)]"":$P(^(0),U,3),1:$P(^(0),U)),1,5)
|
|
S PSJSCHE=$P(UD2,U),QST=$S(PSJSCHE["PRN":"P",1:PST)
|
|
S PSGLOD=$P(UD0,U,14),PSGLSD=$P(UD2,U,2),PSGLFD=$P(UD2,U,4)
|
|
Q:('PSJMPRN&(QST="P"))
|
|
S PSJSI=$S($P(UD0,U,22):"*** NOT TO BE GIVEN ***",1:$P($G(^PS(55,PSGP,5,ON,6)),U))
|
|
S PSJHOLD=$S($P(UD0,U,9)["H":1,1:0)
|
|
D:QST'="P" ADMIN
|
|
I QST="P" S PSJATME=9999,PSJADT=9999999 D @PSGSS
|
|
Q
|
|
;
|
|
ADMIN ;
|
|
S PSGPLO=ON,PSGMFOR="" D ^PSJPL0
|
|
I PSJPLC=1 S PSJATME=8888,PSJADT=8888888 D @PSGSS
|
|
F ADMIN=0:0 S ADMIN=$O(PSGMAR(ADMIN)) Q:'ADMIN S PSJADT=$P(ADMIN,"."),PSJATME=+$E($P(ADMIN,".",2)_"0000",1,4) D @PSGSS
|
|
Q
|
|
;
|
|
P ;*** Set up ^TMP for sort by patients
|
|
NEW QST S QST=$S("CO"[PST:PST,PST="OC":"OA",1:"CR")
|
|
S ^TMP($J,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB
|
|
S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD
|
|
S ^TMP($J,QST,PSGP,ON,1)=PSJSI
|
|
Q
|
|
;
|
|
G ;*** Goto W to set up ^TMP when print by WARD/WARD GROUP
|
|
;
|
|
W ;*** Set up ^TMP when listing by ward
|
|
S:PSGRBADM="A" ^TMP($J,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
|
|
S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
|
|
S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
|
|
S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD
|
|
S ^TMP($J,QST,PSGP,ON,1)=PSJSI
|
|
Q
|