PSGMAR2 ;BIR/CML3-PRINT 24 HOUR MAR(UD) ;14 Oct 98 / 4:28 PM
;;5.0; INPATIENT MEDICATIONS ;**20,111,131,145**;16 DEC 97;Build 17
;
S1 I PSGMARB'=2 S:PSGMARS'=2 (PST,OPST)="C" D:PSGMARS'=2 HEADER^PSGMAR3,BOT^PSGMAR3 S:PSGMARS'=1 (PST,OPST)="P" D:PSGMARS'=1 HEADER^PSGMAR3,BOT^PSGMAR3 Q:PSGMARB=1
D NOW^%DTC S PSGDT=%,(PST,OPST)=""
S PSGMPG=0,PSGMPGN="PAGE: "
I PSGSS="P"!(PSGSS="C")!(PSGSS="L") D P Q
D W
Q
;
P ;***Print on Patient order
;
;
I $O(^TMP($J,PN,PWDN,0))'["C" S (PST,OPST)="C" D HEADER^PSGMAR3,BOT^PSGMAR3 S (PST,OPST)=""
F S PST=$O(^TMP($J,PN,PWDN,PST)) Q:PST="" D:$E(OPST)'=$E(PST) BOT^PSGMAR3:OPST]"",HEADER^PSGMAR3 S OPST=PST,DAO="" D
. F S DAO=$O(^TMP($J,PN,PWDN,PST,DAO)) Q:DAO="" S PSGMARTS=^TMP($J,PN,PWDN,PST,DAO) D PRT
I $O(^TMP($J,PN,PWDN,"CV6"))="" D BOT^PSGMAR3 S (PST,OPST)="O" D HEADER^PSGMAR3
S PSGMPGN="LAST PAGE: " D BOT^PSGMAR3
Q
;
W ;***Print Ward/Ward group
;DAM 5-01-07 Utilize the XTMP global while reverses patient name and location
I $S(PSGRBPPN="P":$O(^XTMP(PSGREP,TM,PN,WDN,RB,0)),1:$O(^TMP($J,TM,WDN,RB,PN,0)))'["C" S (PST,OPST)="C" D HEADER^PSGMAR3,BOT^PSGMAR3 S (PST,OPST)=""
;
D:PSGRBPPN="P" PPN D:PSGRBPPN="R" RB
Q
;
PPN ;***Sort by Patient
;
;DAM - 5-01-07 Utilize the XTMP global set up in PSGMAR0 when printing by WARD/PATIENT or WARD GROUP/PATIENT
F S PST=$O(^XTMP(PSGREP,TM,PN,WDN,RB,PST)) Q:PST="" D:$E(OPST)'=$E(PST) BOT^PSGMAR3:OPST]"",HEADER^PSGMAR3 S OPST=PST,DAO="" D
. F S DAO=$O(^XTMP(PSGREP,TM,PN,WDN,RB,PST,DAO)) Q:DAO="" S PSGMARTS=^(DAO) D PRT
I $O(^XTMP(PSGREP,TM,PN,WDN,RB,"CV6"))="" D BOT^PSGMAR3 S (PST,OPST)="O" D HEADER^PSGMAR3
S PSGMPGN="LAST PAGE: " D BOT^PSGMAR3
;
Q
;
RB ;***Sort by Room bed
F S PST=$O(^TMP($J,TM,WDN,RB,PN,PST)) Q:PST="" D:$E(OPST)'=$E(PST) BOT^PSGMAR3:OPST]"",HEADER^PSGMAR3 S OPST=PST,DAO="" D
. F S DAO=$O(^TMP($J,TM,WDN,RB,PN,PST,DAO)) Q:DAO="" S PSGMARTS=^(DAO) D PRT
I $O(^TMP($J,TM,WDN,RB,PN,"CV6"))="" D BOT^PSGMAR3 S (PST,OPST)="O" D HEADER^PSGMAR3
S PSGMPGN="LAST PAGE: " D BOT^PSGMAR3
Q
;
PRT ; order info
NEW MARLB,DRUGNAME,NAME
S ON=$P(DAO,U,2) D ONHOLD^PSGMMAR2
I +PSGMSORT,$S(ON["V":1,ON["P":$P($G(^PS(53.1,+ON,0)),U,4)="F",1:0) D PRT^PSGMIV Q
D:PSGMAROC>5 ENB^PSGMAR3,HEADER^PSGMAR3 I PST["V" D PRT^PSGMIV Q
S TMSTR=$P(PSGMARTS,"^",2),PSGMARTS=$P(PSGMARTS,"^"),PSGORD=$P(DAO,U,2) S:PSGORD["P" PSJPSTO=PST,PST=$S(+PSGMSORT:"CZ",1:PST) D ^PSGLOI,TS^PSGMAR3(PSGMARTS),MARLB^PSGMUTL(47)
I (PSGMAROC>4&(MARLB>6))!(TS/6>6)!((TS/6+PSGMAROC)>6) D BOT^PSGMAR3,HEADER^PSGMAR3
S PSGMAROC=PSGMAROC+1
NEW PSGX F PSGX=1:1:MARLB W !,MARLB(PSGX) W:PST["C" ?48,"|",$G(TS(PSGX)) D PRT2
I $D(PSJPSTO) S PST=PSJPSTO K PSJPSTO
Q
PRT2 ;
W ?55,"|"
I PSGX=3,(PST'["Z"),(PST["C") D TMSTR^PSGMAR3
I PSGMAROC>5,(TS/6>7) D
. S MSG1="*** CONTINUE ON NEXT PAGE ***"
. D BOT^PSGMAR3,HEADER^PSGMAR3
I PSGX#6=0 W:PSGMAROC<6 !?7,LN2 S:PSGX'=MARLB PSGMAROC=PSGMAROC+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMAR2 2971 printed Apr 09, 2024@21:03:42 Page 2
PSGMAR2 ;BIR/CML3-PRINT 24 HOUR MAR(UD) ;14 Oct 98 / 4:28 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**20,111,131,145**;16 DEC 97;Build 17
+2 ;
S1 IF PSGMARB'=2
if PSGMARS'=2
SET (PST,OPST)="C"
if PSGMARS'=2
DO HEADER^PSGMAR3
DO BOT^PSGMAR3
if PSGMARS'=1
SET (PST,OPST)="P"
if PSGMARS'=1
DO HEADER^PSGMAR3
DO BOT^PSGMAR3
if PSGMARB=1
QUIT
+1 DO NOW^%DTC
SET PSGDT=%
SET (PST,OPST)=""
+2 SET PSGMPG=0
SET PSGMPGN="PAGE: "
+3 IF PSGSS="P"!(PSGSS="C")!(PSGSS="L")
DO P
QUIT
+4 DO W
+5 QUIT
+6 ;
P ;***Print on Patient order
+1 ;
+2 ;
+3 IF $ORDER(^TMP($JOB,PN,PWDN,0))'["C"
SET (PST,OPST)="C"
DO HEADER^PSGMAR3
DO BOT^PSGMAR3
SET (PST,OPST)=""
+4 FOR
SET PST=$ORDER(^TMP($JOB,PN,PWDN,PST))
if PST=""
QUIT
if $EXTRACT(OPST)'=$EXTRACT(PST)
if OPST]""
DO BOT^PSGMAR3
DO HEADER^PSGMAR3
SET OPST=PST
SET DAO=""
Begin DoDot:1
+5 FOR
SET DAO=$ORDER(^TMP($JOB,PN,PWDN,PST,DAO))
if DAO=""
QUIT
SET PSGMARTS=^TMP($JOB,PN,PWDN,PST,DAO)
DO PRT
End DoDot:1
+6 IF $ORDER(^TMP($JOB,PN,PWDN,"CV6"))=""
DO BOT^PSGMAR3
SET (PST,OPST)="O"
DO HEADER^PSGMAR3
+7 SET PSGMPGN="LAST PAGE: "
DO BOT^PSGMAR3
+8 QUIT
+9 ;
W ;***Print Ward/Ward group
+1 ;DAM 5-01-07 Utilize the XTMP global while reverses patient name and location
+2 IF $SELECT(PSGRBPPN="P":$ORDER(^XTMP(PSGREP,TM,PN,WDN,RB,0)),1:$ORDER(^TMP($JOB,TM,WDN,RB,PN,0)))'["C"
SET (PST,OPST)="C"
DO HEADER^PSGMAR3
DO BOT^PSGMAR3
SET (PST,OPST)=""
+3 ;
+4 if PSGRBPPN="P"
DO PPN
if PSGRBPPN="R"
DO RB
+5 QUIT
+6 ;
PPN ;***Sort by Patient
+1 ;
+2 ;DAM - 5-01-07 Utilize the XTMP global set up in PSGMAR0 when printing by WARD/PATIENT or WARD GROUP/PATIENT
+3 FOR
SET PST=$ORDER(^XTMP(PSGREP,TM,PN,WDN,RB,PST))
if PST=""
QUIT
if $EXTRACT(OPST)'=$EXTRACT(PST)
if OPST]""
DO BOT^PSGMAR3
DO HEADER^PSGMAR3
SET OPST=PST
SET DAO=""
Begin DoDot:1
+4 FOR
SET DAO=$ORDER(^XTMP(PSGREP,TM,PN,WDN,RB,PST,DAO))
if DAO=""
QUIT
SET PSGMARTS=^(DAO)
DO PRT
End DoDot:1
+5 IF $ORDER(^XTMP(PSGREP,TM,PN,WDN,RB,"CV6"))=""
DO BOT^PSGMAR3
SET (PST,OPST)="O"
DO HEADER^PSGMAR3
+6 SET PSGMPGN="LAST PAGE: "
DO BOT^PSGMAR3
+7 ;
+8 QUIT
+9 ;
RB ;***Sort by Room bed
+1 FOR
SET PST=$ORDER(^TMP($JOB,TM,WDN,RB,PN,PST))
if PST=""
QUIT
if $EXTRACT(OPST)'=$EXTRACT(PST)
if OPST]""
DO BOT^PSGMAR3
DO HEADER^PSGMAR3
SET OPST=PST
SET DAO=""
Begin DoDot:1
+2 FOR
SET DAO=$ORDER(^TMP($JOB,TM,WDN,RB,PN,PST,DAO))
if DAO=""
QUIT
SET PSGMARTS=^(DAO)
DO PRT
End DoDot:1
+3 IF $ORDER(^TMP($JOB,TM,WDN,RB,PN,"CV6"))=""
DO BOT^PSGMAR3
SET (PST,OPST)="O"
DO HEADER^PSGMAR3
+4 SET PSGMPGN="LAST PAGE: "
DO BOT^PSGMAR3
+5 QUIT
+6 ;
PRT ; order info
+1 NEW MARLB,DRUGNAME,NAME
+2 SET ON=$PIECE(DAO,U,2)
DO ONHOLD^PSGMMAR2
+3 IF +PSGMSORT
IF $SELECT(ON["V":1,ON["P":$PIECE($GET(^PS(53.1,+ON,0)),U,4)="F",1:0)
DO PRT^PSGMIV
QUIT
+4 if PSGMAROC>5
DO ENB^PSGMAR3
DO HEADER^PSGMAR3
IF PST["V"
DO PRT^PSGMIV
QUIT
+5 SET TMSTR=$PIECE(PSGMARTS,"^",2)
SET PSGMARTS=$PIECE(PSGMARTS,"^")
SET PSGORD=$PIECE(DAO,U,2)
if PSGORD["P"
SET PSJPSTO=PST
SET PST=$SELECT(+PSGMSORT:"CZ",1:PST)
DO ^PSGLOI
DO TS^PSGMAR3(PSGMARTS)
DO MARLB^PSGMUTL(47)
+6 IF (PSGMAROC>4&(MARLB>6))!(TS/6>6)!((TS/6+PSGMAROC)>6)
DO BOT^PSGMAR3
DO HEADER^PSGMAR3
+7 SET PSGMAROC=PSGMAROC+1
+8 NEW PSGX
FOR PSGX=1:1:MARLB
WRITE !,MARLB(PSGX)
if PST["C"
WRITE ?48,"|",$GET(TS(PSGX))
DO PRT2
+9 IF $DATA(PSJPSTO)
SET PST=PSJPSTO
KILL PSJPSTO
+10 QUIT
PRT2 ;
+1 WRITE ?55,"|"
+2 IF PSGX=3
IF (PST'["Z")
IF (PST["C")
DO TMSTR^PSGMAR3
+3 IF PSGMAROC>5
IF (TS/6>7)
Begin DoDot:1
+4 SET MSG1="*** CONTINUE ON NEXT PAGE ***"
+5 DO BOT^PSGMAR3
DO HEADER^PSGMAR3
End DoDot:1
+6 IF PSGX#6=0
if PSGMAROC<6
WRITE !?7,LN2
if PSGX'=MARLB
SET PSGMAROC=PSGMAROC+1
+7 QUIT
