PSGMAR1 ;BIR/CML3-SORT ORDERS FOR 24 HOUR MAR ; 7/21/08 9:24am
;;5.0; INPATIENT MEDICATIONS ;**8,111,145,196**;16 DEC 97;Build 13
;
;
SP ; start print
U IO S (LN1,LN2,PSGOP,PN,RB,WDN,TM)="",PSGLSTOP=1,$P(LN1,"-",133)="",$P(LN2,"-",126)=""
K BLN S BLN(1)=$E(LN1,1,20),BLN(2)=" Indicate RIGHT (R)",BLN(3)=" or LEFT (L)",BLN(4)=" 1. DELTOID",BLN(5)=" 2. ABDOMEN",BLN(6)=" 3. ILIAC CREST",BLN(7)=" 4. GLUTEAL",BLN(8)=" 5. THIGH",BLN(9)="PRN: E=Effective",BLN(10)=" N=Not Effective"
I PSGSS="P"!(PSGSS="C")!(PSGSS="L") F S PN=$O(^TMP($J,PN)) Q:PN="" D P
Q:(PSGSS="P")!(PSGSS="C")!(PSGSS="L")
F S (PTM,TM)=$O(^TMP($J,TM)) Q:TM="" F S (PWDN,WDN)=$O(^TMP($J,TM,WDN)) Q:WDN="" D
. I PSGRBPPN="R" F S (PRB,RB)=$O(^TMP($J,TM,WDN,RB)) Q:RB="" F S PN=$O(^TMP($J,TM,WDN,RB,PN)) Q:PN="" S PPN=^(PN) D PI,^PSGMAR2
;
;DAM 5-01-07 - rewrite above lines to utilize the ^XTMP global set up in PSGMAR0 for printing by WARD/PATIENT or WARD GROUP
I PSGRBPPN="P" F S (PTM,TM)=$O(^XTMP(PSGREP,TM)) Q:TM="" F S PN=$O(^XTMP(PSGREP,TM,PN)) Q:PN="" D
. F S (PWDN,WDN)=$O(^XTMP(PSGREP,TM,PN,WDN)) Q:WDN="" D
. . F S (PRB,RB)=$O(^XTMP(PSGREP,TM,PN,WDN,RB)) Q:RB="" S PPN=^(RB) D PI,^PSGMAR2
Q
;
P ;
;
N TMPPWDN
I PSGMARB=1 S PPN=^TMP($J,PN),PWDN=$S(PSGSS="C":$G(PSGAPWDN),1:$P(PPN,U,19)),PRB=$S(PSGSS="C":"",1:$P(PPN,U,20)),PTM="zz" D PI,^PSGMAR2 Q
S TMPPWDN=$P(^TMP($J,PN),U,19)
S:TMPPWDN="" TMPPWDN="zz"
S PWDN=""
F S PWDN=$O(^TMP($J,PN,PWDN)) Q:PWDN="" S TMPPWDN=PWDN S PPN=^TMP($J,PN),PRB=$P(PPN,U,20),PTM="zz" D PI,^PSGMAR2 S PWDN=TMPPWDN
Q
;
PI ; Parses patient information. Does not contain medication info.
K PSGMPG,PSGMPGN
S:PTM="zz" PTM="NOT FOUND" S:PWDN="zz" PWDN="NOT FOUND" S:PRB="zz" PRB="NOT FOUND"
S (PSGOP,PSGP)=+$P(PN,U,2),PSGP(0)=$P(PN,U),BD=$P(PPN,U,2),PSSN=$P(PPN,U,3),DX=$P(PPN,U,4),WT=$P(PPN,U,5)_" "_$P(PPN,U,6)
;GMZ:PSJ*5*196;Set diet info for each patient.
S HT=$P(PPN,U,7)_" "_$P(PPN,U,8),AD=$P(PPN,U,9),TD=$P(PPN,U,10),PSEX=$P(PPN,U,11),PSGLWD=$P(PPN,U,12),PSJDIET=$P($G(PPN),U,21)
S PSGPLS=$P(PPN,U,13),PSGPLF=$P(PPN,U,14),PSGMARSD=$P(PPN,U,15),PSGMARFD=$P(PPN,U,16),PSGMARSP=$P(PPN,U,17),PSGMARFP=$P(PPN,U,18)
S PPN=$P(PPN,U),PAGE=$P(BD,";",2),BD=$P(BD,";"),DFN=PSGP
D ATS^PSJMUTL(115,117,1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMAR1 2292 printed Sep 23, 2025@19:37:35 Page 2
PSGMAR1 ;BIR/CML3-SORT ORDERS FOR 24 HOUR MAR ; 7/21/08 9:24am
+1 ;;5.0; INPATIENT MEDICATIONS ;**8,111,145,196**;16 DEC 97;Build 13
+2 ;
+3 ;
SP ; start print
+1 USE IO
SET (LN1,LN2,PSGOP,PN,RB,WDN,TM)=""
SET PSGLSTOP=1
SET $PIECE(LN1,"-",133)=""
SET $PIECE(LN2,"-",126)=""
+2 KILL BLN
SET BLN(1)=$EXTRACT(LN1,1,20)
SET BLN(2)=" Indicate RIGHT (R)"
SET BLN(3)=" or LEFT (L)"
SET BLN(4)=" 1. DELTOID"
SET BLN(5)=" 2. ABDOMEN"
SET BLN(6)=" 3. ILIAC CREST"
SET BLN(7)=" 4. GLUTEAL"
SET BLN(8)=" 5. THIGH"
SET BLN(9)="PRN: E=Effective"
SET BLN(10)=" N=Not Effective"
+3 IF PSGSS="P"!(PSGSS="C")!(PSGSS="L")
FOR
SET PN=$ORDER(^TMP($JOB,PN))
if PN=""
QUIT
DO P
+4 if (PSGSS="P")!(PSGSS="C")!(PSGSS="L")
QUIT
+5 FOR
SET (PTM,TM)=$ORDER(^TMP($JOB,TM))
if TM=""
QUIT
FOR
SET (PWDN,WDN)=$ORDER(^TMP($JOB,TM,WDN))
if WDN=""
QUIT
Begin DoDot:1
+6 IF PSGRBPPN="R"
FOR
SET (PRB,RB)=$ORDER(^TMP($JOB,TM,WDN,RB))
if RB=""
QUIT
FOR
SET PN=$ORDER(^TMP($JOB,TM,WDN,RB,PN))
if PN=""
QUIT
SET PPN=^(PN)
DO PI
DO ^PSGMAR2
End DoDot:1
+7 ;
+8 ;DAM 5-01-07 - rewrite above lines to utilize the ^XTMP global set up in PSGMAR0 for printing by WARD/PATIENT or WARD GROUP
+9 IF PSGRBPPN="P"
FOR
SET (PTM,TM)=$ORDER(^XTMP(PSGREP,TM))
if TM=""
QUIT
FOR
SET PN=$ORDER(^XTMP(PSGREP,TM,PN))
if PN=""
QUIT
Begin DoDot:1
+10 FOR
SET (PWDN,WDN)=$ORDER(^XTMP(PSGREP,TM,PN,WDN))
if WDN=""
QUIT
Begin DoDot:2
+11 FOR
SET (PRB,RB)=$ORDER(^XTMP(PSGREP,TM,PN,WDN,RB))
if RB=""
QUIT
SET PPN=^(RB)
DO PI
DO ^PSGMAR2
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
P ;
+1 ;
+2 NEW TMPPWDN
+3 IF PSGMARB=1
SET PPN=^TMP($JOB,PN)
SET PWDN=$SELECT(PSGSS="C":$GET(PSGAPWDN),1:$PIECE(PPN,U,19))
SET PRB=$SELECT(PSGSS="C":"",1:$PIECE(PPN,U,20))
SET PTM="zz"
DO PI
DO ^PSGMAR2
QUIT
+4 SET TMPPWDN=$PIECE(^TMP($JOB,PN),U,19)
+5 if TMPPWDN=""
SET TMPPWDN="zz"
+6 SET PWDN=""
+7 FOR
SET PWDN=$ORDER(^TMP($JOB,PN,PWDN))
if PWDN=""
QUIT
SET TMPPWDN=PWDN
SET PPN=^TMP($JOB,PN)
SET PRB=$PIECE(PPN,U,20)
SET PTM="zz"
DO PI
DO ^PSGMAR2
SET PWDN=TMPPWDN
+8 QUIT
+9 ;
PI ; Parses patient information. Does not contain medication info.
+1 KILL PSGMPG,PSGMPGN
+2 if PTM="zz"
SET PTM="NOT FOUND"
if PWDN="zz"
SET PWDN="NOT FOUND"
if PRB="zz"
SET PRB="NOT FOUND"
+3 SET (PSGOP,PSGP)=+$PIECE(PN,U,2)
SET PSGP(0)=$PIECE(PN,U)
SET BD=$PIECE(PPN,U,2)
SET PSSN=$PIECE(PPN,U,3)
SET DX=$PIECE(PPN,U,4)
SET WT=$PIECE(PPN,U,5)_" "_$PIECE(PPN,U,6)
+4 ;GMZ:PSJ*5*196;Set diet info for each patient.
+5 SET HT=$PIECE(PPN,U,7)_" "_$PIECE(PPN,U,8)
SET AD=$PIECE(PPN,U,9)
SET TD=$PIECE(PPN,U,10)
SET PSEX=$PIECE(PPN,U,11)
SET PSGLWD=$PIECE(PPN,U,12)
SET PSJDIET=$PIECE($GET(PPN),U,21)
+6 SET PSGPLS=$PIECE(PPN,U,13)
SET PSGPLF=$PIECE(PPN,U,14)
SET PSGMARSD=$PIECE(PPN,U,15)
SET PSGMARFD=$PIECE(PPN,U,16)
SET PSGMARSP=$PIECE(PPN,U,17)
SET PSGMARFP=$PIECE(PPN,U,18)
+7 SET PPN=$PIECE(PPN,U)
SET PAGE=$PIECE(BD,";",2)
SET BD=$PIECE(BD,";")
SET DFN=PSGP
+8 DO ATS^PSJMUTL(115,117,1)
+9 QUIT
