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