- 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 Feb 18, 2025@23:27:53 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