PSGMMAR1 ;BIR/CML3-PRINTS MD MAR ; 8/14/08 11:07am
;;5.0; INPATIENT MEDICATIONS ;**3,8,92,111,145,196**;16 DEC 97;Build 13
;
;
SP ; start print
U IO S WG=$S($D(^TMP($J))#2:+^($J),1:0),WGN=$S('$D(^PS(57.5,WG,0)):WG,$P(^(0),"^")]"":$P(^(0),"^"),1:WG),(LN1,LN2,PSGOP,PN,RB,WDN,TM)="",PSGLSTOP=1,$P(LN1,"-",133)="",$P(LN2,"-",126)=""
S MOS="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",(LN3,LN14,QQ)=""
F Q=0:0 S Q=$O(PSGD(Q)) Q:'Q S LN3=LN3_" "_$E(" ",1,PSGMARDF=7+1)_$S(PSGMARDF=7:$P(PSGD(Q),"^"),1:$E(Q,6,7))_$E(" ",1,PSGMARDF=7+1) S:PSGMARDF=7 QQ=Q I PSGMARDF=14 S LN14=LN14_" "_$S($E(Q,4,5)'=$E(QQ,4,5):$P(MOS,"^",+PSGD(Q)),1:" "),QQ=Q
S (LN4,LN7)="|" F Q=1:1:PSGMARDF S LN4=LN4_$E("_________",1,$S(PSGMARDF=7:9,1:4))_"|",LN7=LN7_$E(" ",1,$S(PSGMARDF=7:9,1:4))_"|"
S LN5="|-------|-------|----------------------|------|----------------------|------|",LN6=" DATE TIME REASON INIT RESULT INIT"
S LN31="|--------|--------|-----------------------------------------|------|-----------------------|-----------------------|--------|------|"
S LN32="| | | | | | | | |"
K BLN S BLN(1)=$E(LN1,1,36),BLN(2)=" Indicate RIGHT (R) or LEFT (L)",BLN(3)="",BLN(4)=" (IM) (SUB Q)",BLN(5)="1. DELTOID 6. UPPER ARM",BLN(6)="2. VENTRAL GLUTEAL 7. ABDOMEN"
S BLN(7)="3. GLUTEUS MEDIUS 8. THIGH",BLN(8)="4. MID(ANTERIOR) THIGH 9. BUTTOCK",BLN(9)="5. VASTUS LATERALIS 10. UPPER BACK",BLN(10)=" PRN: E=Effective N=Not Effective"
S ASTERS=$E("*********",1,PSGMARDF=7*5+4),EXPIRE=$S(PSGMARDF=14:"****",1:"*********"),SPACES=$E(" ",1,PSGMARDF=7*5+4) F X="PSGMARSD","PSGMARFD" S @($E(X,1,7)_"P")=$P($$ENDTC2^PSGMI(@X)," ")
;
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,^PSGMMAR2:PSGMARS'=2,BLANK^PSGMMAR3:(PSGMARS=2&(PSGMARB'=2)),^PSGMMAR3:PSGMARS'=1
;
;DAM 5-01-07 - Utilize the ^XTMP global set up in PSGMMAR0 for printing by WARD/PATIENT or WARD GROUP/PATIENT
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,^PSGMMAR2:PSGMARS'=2,BLANK^PSGMMAR3:(PSGMARS=2&(PSGMARB'=2)),^PSGMMAR3:PSGMARS'=1
Q
;
P ;
;
N TMPPWDN
I (PSGMARB=1)!($D(^TMP($J,PN))=1) D Q
. S PPN=^TMP($J,PN),PWDN=$S(PSGSS="C":$G(PSGAPWDN),1:$P(PPN,U,13)),PRB=$S(PSGSS="C":"",1:$P(PPN,U,14)),PTM="zz"
. D PI
. I PSGMARS'=2 D ^PSGMMAR2
. I PSGMARS'=1 D:(PSGMARS=2&(PSGMARB'=2)) BLANK^PSGMMAR3 D ^PSGMMAR3
. Q
;
S TMPPWDN=$P(^TMP($J,PN),U,13)
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,14),PTM="zz" D S PWDN=TMPPWDN
. D PI
. I PSGMARS'=2 D ^PSGMMAR2
. I PSGMARS'=1 D:(PSGMARS=2&(PSGMARB'=2)) BLANK^PSGMMAR3 D ^PSGMMAR3
. Q
;
Q
;
PI ;
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),PSJDIET=$P($G(PPN),U,15)
S TD=$P(PPN,U,10),PSEX=$P(PPN,U,11),PSGLWD=$P(PPN,U,12),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[HPSGMMAR1 3834 printed Dec 13, 2024@02:01:35 Page 2
PSGMMAR1 ;BIR/CML3-PRINTS MD MAR ; 8/14/08 11:07am
+1 ;;5.0; INPATIENT MEDICATIONS ;**3,8,92,111,145,196**;16 DEC 97;Build 13
+2 ;
+3 ;
SP ; start print
+1 USE IO
SET WG=$SELECT($DATA(^TMP($JOB))#2:+^($JOB),1:0)
SET WGN=$SELECT('$DATA(^PS(57.5,WG,0)):WG,$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:WG)
SET (LN1,LN2,PSGOP,PN,RB,WDN,TM)=""
SET PSGLSTOP=1
SET $PIECE(LN1,"-",133)=""
SET $PIECE(LN2,"-",126)=""
+2 SET MOS="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"
SET (LN3,LN14,QQ)=""
+3 FOR Q=0:0
SET Q=$ORDER(PSGD(Q))
if 'Q
QUIT
SET LN3=LN3_" "_$EXTRACT(" ",1,PSGMARDF=7+1)_$SELECT(PSGMARDF=7:$PIECE(PSGD(Q),"^"),1:$EXTRACT(Q,6,7))_$EXTRACT(" ",1,PSGMARDF=7+1)
if PSGMARDF=7
SET QQ=Q
IF PSGMARDF=14
SET LN14=LN14_" "_$SELECT($EXTRACT(Q,4,5)'=$EXTRACT(QQ,4,5):$PIECE(MOS,"^",+PSGD(Q)),1:" ")
SET QQ=Q
+4 SET (LN4,LN7)="|"
FOR Q=1:1:PSGMARDF
SET LN4=LN4_$EXTRACT("_________",1,$SELECT(PSGMARDF=7:9,1:4))_"|"
SET LN7=LN7_$EXTRACT(" ",1,$SELECT(PSGMARDF=7:9,1:4))_"|"
+5 SET LN5="|-------|-------|----------------------|------|----------------------|------|"
SET LN6=" DATE TIME REASON INIT RESULT INIT"
+6 SET LN31="|--------|--------|-----------------------------------------|------|-----------------------|-----------------------|--------|------|"
+7 SET LN32="| | | | | | | | |"
+8 KILL BLN
SET BLN(1)=$EXTRACT(LN1,1,36)
SET BLN(2)=" Indicate RIGHT (R) or LEFT (L)"
SET BLN(3)=""
SET BLN(4)=" (IM) (SUB Q)"
SET BLN(5)="1. DELTOID 6. UPPER ARM"
SET BLN(6)="2. VENTRAL GLUTEAL 7. ABDOMEN"
+9 SET BLN(7)="3. GLUTEUS MEDIUS 8. THIGH"
SET BLN(8)="4. MID(ANTERIOR) THIGH 9. BUTTOCK"
SET BLN(9)="5. VASTUS LATERALIS 10. UPPER BACK"
SET BLN(10)=" PRN: E=Effective N=Not Effective"
+10 SET ASTERS=$EXTRACT("*********",1,PSGMARDF=7*5+4)
SET EXPIRE=$SELECT(PSGMARDF=14:"****",1:"*********")
SET SPACES=$EXTRACT(" ",1,PSGMARDF=7*5+4)
FOR X="PSGMARSD","PSGMARFD"
SET @($EXTRACT(X,1,7)_"P")=$PIECE($$ENDTC2^PSGMI(@X)," ")
+11 ;
+12 IF PSGSS="P"!(PSGSS="C")!(PSGSS="L")
FOR
SET PN=$ORDER(^TMP($JOB,PN))
if PN=""
QUIT
DO P
+13 if (PSGSS="P")!(PSGSS="C")!(PSGSS="L")
QUIT
+14 ;
+15 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
+16 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
if PSGMARS'=2
DO ^PSGMMAR2
if (PSGMARS=2&(PSGMARB'=2))
DO BLANK^PSGMMAR3
if PSGMARS'=1
DO ^PSGMMAR3
End DoDot:1
+17 ;
+18 ;DAM 5-01-07 - Utilize the ^XTMP global set up in PSGMMAR0 for printing by WARD/PATIENT or WARD GROUP/PATIENT
+19 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
+20 FOR
SET (PWDN,WDN)=$ORDER(^XTMP(PSGREP,TM,PN,WDN))
if WDN=""
QUIT
Begin DoDot:2
+21 FOR
SET (PRB,RB)=$ORDER(^XTMP(PSGREP,TM,PN,WDN,RB))
if RB=""
QUIT
SET PPN=^(RB)
DO PI
if PSGMARS'=2
DO ^PSGMMAR2
if (PSGMARS=2&(PSGMARB'=2))
DO BLANK^PSGMMAR3
if PSGMARS'=1
DO ^PSGMMAR3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
P ;
+1 ;
+2 NEW TMPPWDN
+3 IF (PSGMARB=1)!($DATA(^TMP($JOB,PN))=1)
Begin DoDot:1
+4 SET PPN=^TMP($JOB,PN)
SET PWDN=$SELECT(PSGSS="C":$GET(PSGAPWDN),1:$PIECE(PPN,U,13))
SET PRB=$SELECT(PSGSS="C":"",1:$PIECE(PPN,U,14))
SET PTM="zz"
+5 DO PI
+6 IF PSGMARS'=2
DO ^PSGMMAR2
+7 IF PSGMARS'=1
if (PSGMARS=2&(PSGMARB'=2))
DO BLANK^PSGMMAR3
DO ^PSGMMAR3
+8 QUIT
End DoDot:1
QUIT
+9 ;
+10 SET TMPPWDN=$PIECE(^TMP($JOB,PN),U,13)
+11 if TMPPWDN=""
SET TMPPWDN="zz"
+12 SET PWDN=""
+13 FOR
SET PWDN=$ORDER(^TMP($JOB,PN,PWDN))
if PWDN=""
QUIT
SET TMPPWDN=PWDN
SET PPN=^TMP($JOB,PN)
SET PRB=$PIECE(PPN,U,14)
SET PTM="zz"
Begin DoDot:1
+14 DO PI
+15 IF PSGMARS'=2
DO ^PSGMMAR2
+16 IF PSGMARS'=1
if (PSGMARS=2&(PSGMARB'=2))
DO BLANK^PSGMMAR3
DO ^PSGMMAR3
+17 QUIT
End DoDot:1
SET PWDN=TMPPWDN
+18 ;
+19 QUIT
+20 ;
PI ;
+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 PSJDIET=$PIECE($GET(PPN),U,15)
+6 SET TD=$PIECE(PPN,U,10)
SET PSEX=$PIECE(PPN,U,11)
SET PSGLWD=$PIECE(PPN,U,12)
SET PPN=$PIECE(PPN,U)
SET PAGE=$PIECE(BD,";",2)
SET BD=$PIECE(BD,";")
SET DFN=PSGP
+7 DO ATS^PSJMUTL(115,117,1)
+8 QUIT
