- PSGMMAR2 ;BIR/CML3-MD MARS - PRINT C ORDERS(UD) ;09 Feb 99 / 12:50 PM
- ;;5.0; INPATIENT MEDICATIONS ;**8,20,111,131,145**;16 DEC 97;Build 17
- ; Reference to ^PS(55 is supported by DBIA# 2191
- S1 ;
- I PSGMARB'=1 S:PSGRBPPN="P" X=PN,Y=RB S:PSGRBPPN="R" X=RB,Y=PN D
- . I PSGRBPPN="R" S NO=$S(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):$O(^TMP($J,PN,PWDN,0)),1:$O(^TMP($J,TM,WDN,X,Y,0)))'["C"
- . I PSGRBPPN="P" S NO=$S(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):$O(^TMP($J,PN,PWDN,0)),1:$O(^XTMP(PSGREP,TM,X,WDN,Y,0)))'["C" ;DAM 5-01-07 Rewrite to utilize XTMP global when printing by WARD/PATIENT or WARD GROUP/PATIENT
- ;
- I (PSGSS="P")!(PSGSS="C")!(PSGSS="L") S NO=$S(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):$O(^TMP($J,PN,PWDN,0)),1:$O(^TMP($J,TM,WDN,X,Y,0)))'["C"
- ;
- I $S(PSGMARB'=2:1,"34"[PSGMARS:NO,1:0) D:(PSGMARS'=4) HEADER,BOT D:PSGMARS'=1 BLANK^PSGMMAR3 Q:PSGMARB=1
- ;
- Q:NO D NOW^%DTC S PSGDT=%,(DAO,PST)="" I PSGSS'="P",PSGSS'="C",PSGSS'="L" D HEADER
- ;
- S PSGMPG=0,PSGMPGN="PAGE: "
- D @($S(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):"P",1:"W"))
- D BOT
- Q
- P ; Print on Patient order
- ;
- D HEADER
- F S PST=$O(^TMP($J,PN,PWDN,PST)) Q:PST'["C" D
- . S DAO=""
- . F S DAO=$O(^TMP($J,PN,PWDN,PST,DAO)) Q:DAO="" S PSGMARTS=^TMP($J,PN,PWDN,PST,DAO) D PRT
- . Q
- ;
- S:$O(^TMP($J,PN,PWDN,"N"))="" PSGMPGN="LAST PAGE: "
- Q
- ;
- W ; Print Ward/Ward group
- ;DAM 5-01-07 Utilize the XTMP global for printing by WARD/PATIENT or WARD GROUP/PATIENT
- I PSGRBPPN="P" D
- . F S PST=$O(^XTMP(PSGREP,TM,PN,WDN,RB,PST)) Q:PST'["C" F Q=0:0 S DAO=$O(^XTMP(PSGREP,TM,PN,WDN,RB,PST,DAO)) Q:DAO="" S PSGMARTS=^(DAO) D PRT
- . ;
- . S:$O(^XTMP(PSGREP,TM,PN,WDN,RB,"N"))="" PSGMPGN="LAST PAGE: "
- . ;
- I PSGRBPPN="R" D
- . F S PST=$O(^TMP($J,TM,WDN,RB,PN,PST)) Q:PST'["C" F Q=0:0 S DAO=$O(^TMP($J,TM,WDN,RB,PN,PST,DAO)) Q:DAO="" S PSGMARTS=^(DAO) D PRT
- . S:$O(^TMP($J,TM,WDN,RB,PN,"N"))="" PSGMPGN="LAST PAGE: "
- Q
- S:'$G(PSGXDT) PSGXDT=PSGDT ;Reason was that PSGDT kept reset somewhere
- S PSGMAROC=0,(MSG1,MSG2)="" W:$G(PSGPG)&($Y) @IOF S PSGPG=1 W !?1,"CONTINUOUS SHEET",?61,PSGMARDF," DAY MAR",?100,PSGMARSP," through ",PSGMARFP
- W !?5,$P($$SITE(80),U,2),?102,"Printed on "_$$ENDTC2^PSGMI(PSGXDT)
- W !?5,"Name: "_PPN,?62,"Weight (kg): "_WT,?103,"Loc: "_$S(PWDN'["C!":PWDN,1:$P($G(^SC($P(PWDN,"!",2),0)),"^"))
- W !?6,"PID: "_PSSN,?25,"DOB: "_BD_" ("_PAGE_")",?62,"Height (cm): "_HT,?99,"Room-Bed: "_$S(PWDN'["C!":PRB,1:"")
- W !?6,"Sex: "_PSEX,?25," Dx: "_DX,?$S(TD:94,1:99),$S(TD:"Last Transfer: "_TD,1:"Admitted: "_$S(PWDN'["C!":AD,1:""))
- I '$D(PSGALG) W !,"Allergies: See attached list of Allergies/Adverse Reactions"
- NEW PSGX S PSGX=0 D ATS^PSGMAR3(.PSGX) D:PSGX HEADER Q:PSGX
- W !,?49,"Admin"
- W:$G(PSJDIET)]"" ?57,"Diet: ",PSJDIET
- W:PSGMARDF=14 ?55,LN14 W !?1,"Order",?9,"Start",?21,"Stop",?49,"Times" W ?55,LN3," notes",!,LN1
- Q
- PRT ; order info
- S ON=$P(DAO,U,2) D ONHOLD
- I +PSGMSORT,$S(ON["V":1,ON["P":$P($G(^PS(53.1,+ON,0)),U,4)="F",1:0) D PRT^PSGMMIVC Q
- D:PSGMAROC>5 ENB,HEADER I PST["CV"!(PST["CZV") D PRT^PSGMMIVC Q
- S PSGMARGD=$P(PSGMARTS,"^",2),PSGMARTS=$P(PSGMARTS,"^"),PSGORD=$P(DAO,U,2) S:PSGORD["P" PSJPSTO=PST,PST=$S(+PSGMSORT:"CZ",1:PST) D ^PSGLOI
- D TS^PSGMAR3(PSGMARTS)
- D MARLB^PSGMUTL(47)
- I (PSGMAROC>4&(MARLB>6))!(TS/6>6)!((TS/6+PSGMAROC)>6) D BOT,HEADER
- S PSGMAROC=PSGMAROC+1
- NEW PRTLN F PRTLN=1:1:MARLB W !,MARLB(PRTLN),?48,"|",$G(TS(PRTLN)) D CELL(PRTLN,'(PRTLN#6)) D PRT2
- I $D(PSJPSTO) S PST=PSJPSTO K PSJPSTO
- Q
- PRT2 ;
- I PSGMAROC>5,(TS/6>7) D
- . S MSG1="*** CONTINUE ON NEXT PAGE ***"
- . D BOT,HEADER
- I PRTLN#6=0 W:PSGMAROC<6 !?7,LN2 S:PRTLN'=MARLB PSGMAROC=PSGMAROC+1
- Q
- CHKLAB ; Check to see if next label is needed.
- I '((L+1)#6) W ?48,"| ",$G(TS(L)) D CELL(L,0) W !?1,"See next label for continuation",?48,"| ",$G(TS(L+1)) D CELL(L+1,1) W:PSGMAROC<6 !?7,LN2,!?1 S L=L+2,PSGMAROC=PSGMAROC+1 D Q
- . I PSGMAROC>5,(TS/6>7) S MSG1="*** CONTINUE ON NEXT PAGE ***" D BOT,HEADER
- E W ?48,"| ",$G(TS(L)) D CELL(L,0) W !?1 S L=L+1
- Q
- INIT ; Print the initials on the label.
- W !?1,$E("WS",1,PSGLWS*2),?4,$S(PSGLSM:$E("HSM",PSGLSM,3),1:""),?8,$E("NF",1,PSGLNF*2),?30,"RPH: ",PSGLRPH,?39," RN: ",PSGLRN,?48,"| ",?50,$G(TS(L)) D CELL(L,1)
- Q
- CELL(X,X1) ; Print the **** on the not to be given cells.
- N QTS,CELL S CELL=$E($S(X1:" ",1:"_________"),1,PSGMARDF=7*5+4)
- I PST["CZ",(X=6) NEW PSGLFFD,PSGMARGD S P(9)="",PSGLFFD="9999999",PSGMARGD="" W ?55 D ASTERS Q
- I TS=1,'PSGMARTS,(X=6) W ?55 S P(9)=1 D ASTERS K P(9) Q
- I $G(TS(X))="" W ?55,$S(X1:LN7,1:LN4) Q
- F Q=0:0 S Q=$O(PSGD(Q)) Q:'Q S QTS=Q_"."_TS(X) W ?55,"|"_$S(QTS<PSGLSSD:EXPIRE,QTS'<PSGLFFD:EXPIRE,PSGMARGD="":ASTERS,$G(ONHOLD):$E("Hold ",1,$L(CELL)),PSGMARGD[$P(PSGD(Q),"^"):CELL,1:ASTERS)
- W "|"
- Q
- ASTERS ; Print the **** on the first label.
- I ONHOLD N HSPACE S HSPACE=SPACES,SPACES=$E("Hold ",1,$L(HSPACE))
- S PSGLFFD=$P(PSGLFFD,".") F Q=0:0 S Q=$O(PSGD(Q)) Q:'Q W "|"_$S(Q<$P(PSGLSSD,"."):ASTERS,Q=PSGLFFD:EXPIRE,Q>PSGLFFD:ASTERS,(PSGMARGD=""&($G(P(9))="")):SPACES,PSGMARGD[$P(PSGD(Q),"^"):SPACES,1:ASTERS)
- W "|"
- I ONHOLD S SPACES=HSPACE
- Q
- BOT ; bottom of MAR
- I MSG1]"" F QQ=1:1:6 W ! W:QQ=1 ?6,"|",?19,"|" W:34[QQ ?12,$S(QQ=3:MSG1,1:MSG2) W ?55,$S(QQ<6:LN4,1:LN7)
- I PSGMAROC<6 S PSGMAROC=6-PSGMAROC F Q=1:1:PSGMAROC F QQ=1:1:6 W ! W:QQ=1 ?6,"|",?19,"|" W:34[QQ ?12,$S(QQ=3:MSG1,1:MSG2) W ?55,$S(QQ<6:LN4,1:LN7) I QQ=6,Q<PSGMAROC W !?7,LN2
- ENB ;
- I $D(PSGMPG) S PSGMPG=PSGMPG+1 S PSGMPGN=$S(PSGMPGN'["LAST":"PAGE: ",1:PSGMPGN)_PSGMPG
- W !,LN1
- W !,"|",?11,"SIGNATURE/TITLE",?38,"| INIT | INJECTION SITES |",?87,"MED/DOSE OMITTED",?107,"| REASON | INIT |"
- F Q=1:1:10 W !,"|"_$E(LN1,1,37)_"|------|"_BLN(Q),?82,"|"_$E(LN1,1,24)_"|"_$E(LN1,1,16)_"|------|"
- W !,LN1,!?3,PPN,?45,PSSN,?58,"Room-Bed: "_$S(PWDN'["C!":PRB,1:""),?100,$S($D(PSGMPG):PSGMPGN,1:""),?116,"VA FORM 10-2970",*13
- Q
- SITE(LEN) ;* Get the Institution name
- ;* Input : LEN = Report width (80 or 132 column)
- ;* Output: space needed to center text ^ VAMC name
- NEW X
- S X=$$NAME^VASITE
- I X="" S X=$$SITE^VASITE S:X]"" X="VAMC: "_$P(X,U,2)_" ("_$P(X,U,3)_")"
- I X="" Q ""
- Q (LEN-$L(X))/2_U_X
- ONHOLD ;Check order to see if it's ON hold, set Flag True if it is
- S ONHOLD=0
- N PSGON
- S PSGON=+ON
- ;If unit dose order, check Hold Status field = Active Hold
- I (ON["A")!(ON["O")!(ON["U") I $P($G(^PS(55,$P(PN,"^",2),5,PSGON,0)),"^",9)="H" S ONHOLD=1 Q
- ;If IV Order, check Status field = Hold
- I ON["V" I $P($G(^PS(55,$P(PN,"^",2),"IV",PSGON,0)),"^",17)="H" S ONHOLD=1 Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMMAR2 6595 printed Jan 18, 2025@03:02:50 Page 2
- PSGMMAR2 ;BIR/CML3-MD MARS - PRINT C ORDERS(UD) ;09 Feb 99 / 12:50 PM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**8,20,111,131,145**;16 DEC 97;Build 17
- +2 ; Reference to ^PS(55 is supported by DBIA# 2191
- S1 ;
- +1 IF PSGMARB'=1
- if PSGRBPPN="P"
- SET X=PN
- SET Y=RB
- if PSGRBPPN="R"
- SET X=RB
- SET Y=PN
- Begin DoDot:1
- +2 IF PSGRBPPN="R"
- SET NO=$SELECT(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):$ORDER(^TMP($JOB,PN,PWDN,0)),1:$ORDER(^TMP($JOB,TM,WDN,X,Y,0)))'["C"
- +3 ;DAM 5-01-07 Rewrite to utilize XTMP global when printing by WARD/PATIENT or WARD GROUP/PATIENT
- IF PSGRBPPN="P"
- SET NO=$SELECT(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):$ORDER(^TMP($JOB,PN,PWDN,0)),1:$ORDER(^XTMP(PSGREP,TM,X,WDN,Y,0)))'["C"
- End DoDot:1
- +4 ;
- +5 IF (PSGSS="P")!(PSGSS="C")!(PSGSS="L")
- SET NO=$SELECT(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):$ORDER(^TMP($JOB,PN,PWDN,0)),1:$ORDER(^TMP($JOB,TM,WDN,X,Y,0)))'["C"
- +6 ;
- +7 IF $SELECT(PSGMARB'=2:1,"34"[PSGMARS:NO,1:0)
- if (PSGMARS'=4)
- DO HEADER
- DO BOT
- if PSGMARS'=1
- DO BLANK^PSGMMAR3
- if PSGMARB=1
- QUIT
- +8 ;
- +9 if NO
- QUIT
- DO NOW^%DTC
- SET PSGDT=%
- SET (DAO,PST)=""
- IF PSGSS'="P"
- IF PSGSS'="C"
- IF PSGSS'="L"
- DO HEADER
- +10 ;
- +11 SET PSGMPG=0
- SET PSGMPGN="PAGE: "
- +12 DO @($SELECT(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):"P",1:"W"))
- +13 DO BOT
- +14 QUIT
- P ; Print on Patient order
- +1 ;
- +2 DO HEADER
- +3 FOR
- SET PST=$ORDER(^TMP($JOB,PN,PWDN,PST))
- if PST'["C"
- QUIT
- Begin DoDot:1
- +4 SET DAO=""
- +5 FOR
- SET DAO=$ORDER(^TMP($JOB,PN,PWDN,PST,DAO))
- if DAO=""
- QUIT
- SET PSGMARTS=^TMP($JOB,PN,PWDN,PST,DAO)
- DO PRT
- +6 QUIT
- End DoDot:1
- +7 ;
- +8 if $ORDER(^TMP($JOB,PN,PWDN,"N"))=""
- SET PSGMPGN="LAST PAGE: "
- +9 QUIT
- +10 ;
- W ; Print Ward/Ward group
- +1 ;DAM 5-01-07 Utilize the XTMP global for printing by WARD/PATIENT or WARD GROUP/PATIENT
- +2 IF PSGRBPPN="P"
- Begin DoDot:1
- +3 FOR
- SET PST=$ORDER(^XTMP(PSGREP,TM,PN,WDN,RB,PST))
- if PST'["C"
- QUIT
- FOR Q=0:0
- SET DAO=$ORDER(^XTMP(PSGREP,TM,PN,WDN,RB,PST,DAO))
- if DAO=""
- QUIT
- SET PSGMARTS=^(DAO)
- DO PRT
- +4 ;
- +5 if $ORDER(^XTMP(PSGREP,TM,PN,WDN,RB,"N"))=""
- SET PSGMPGN="LAST PAGE: "
- +6 ;
- End DoDot:1
- +7 IF PSGRBPPN="R"
- Begin DoDot:1
- +8 FOR
- SET PST=$ORDER(^TMP($JOB,TM,WDN,RB,PN,PST))
- if PST'["C"
- QUIT
- FOR Q=0:0
- SET DAO=$ORDER(^TMP($JOB,TM,WDN,RB,PN,PST,DAO))
- if DAO=""
- QUIT
- SET PSGMARTS=^(DAO)
- DO PRT
- +9 if $ORDER(^TMP($JOB,TM,WDN,RB,PN,"N"))=""
- SET PSGMPGN="LAST PAGE: "
- End DoDot:1
- +10 QUIT
- +1 ;Reason was that PSGDT kept reset somewhere
- if '$GET(PSGXDT)
- SET PSGXDT=PSGDT
- +2 SET PSGMAROC=0
- SET (MSG1,MSG2)=""
- if $GET(PSGPG)&($Y)
- WRITE @IOF
- SET PSGPG=1
- WRITE !?1,"CONTINUOUS SHEET",?61,PSGMARDF," DAY MAR",?100,PSGMARSP," through ",PSGMARFP
- +3 WRITE !?5,$PIECE($$SITE(80),U,2),?102,"Printed on "_$$ENDTC2^PSGMI(PSGXDT)
- +4 WRITE !?5,"Name: "_PPN,?62,"Weight (kg): "_WT,?103,"Loc: "_$SELECT(PWDN'["C!":PWDN,1:$PIECE($GET(^SC($PIECE(PWDN,"!",2),0)),"^"))
- +5 WRITE !?6,"PID: "_PSSN,?25,"DOB: "_BD_" ("_PAGE_")",?62,"Height (cm): "_HT,?99,"Room-Bed: "_$SELECT(PWDN'["C!":PRB,1:"")
- +6 WRITE !?6,"Sex: "_PSEX,?25," Dx: "_DX,?$SELECT(TD:94,1:99),$SELECT(TD:"Last Transfer: "_TD,1:"Admitted: "_$SELECT(PWDN'["C!":AD,1:""))
- +7 IF '$DATA(PSGALG)
- WRITE !,"Allergies: See attached list of Allergies/Adverse Reactions"
- +8 NEW PSGX
- SET PSGX=0
- DO ATS^PSGMAR3(.PSGX)
- if PSGX
- DO HEADER
- if PSGX
- QUIT
- +9 WRITE !,?49,"Admin"
- +10 if $GET(PSJDIET)]""
- WRITE ?57,"Diet: ",PSJDIET
- +11 if PSGMARDF=14
- WRITE ?55,LN14
- WRITE !?1,"Order",?9,"Start",?21,"Stop",?49,"Times"
- WRITE ?55,LN3," notes",!,LN1
- +12 QUIT
- PRT ; order info
- +1 SET ON=$PIECE(DAO,U,2)
- DO ONHOLD
- +2 IF +PSGMSORT
- IF $SELECT(ON["V":1,ON["P":$PIECE($GET(^PS(53.1,+ON,0)),U,4)="F",1:0)
- DO PRT^PSGMMIVC
- QUIT
- +3 if PSGMAROC>5
- DO ENB
- DO HEADER
- IF PST["CV"!(PST["CZV")
- DO PRT^PSGMMIVC
- QUIT
- +4 SET PSGMARGD=$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
- +5 DO TS^PSGMAR3(PSGMARTS)
- +6 DO MARLB^PSGMUTL(47)
- +7 IF (PSGMAROC>4&(MARLB>6))!(TS/6>6)!((TS/6+PSGMAROC)>6)
- DO BOT
- DO HEADER
- +8 SET PSGMAROC=PSGMAROC+1
- +9 NEW PRTLN
- FOR PRTLN=1:1:MARLB
- WRITE !,MARLB(PRTLN),?48,"|",$GET(TS(PRTLN))
- DO CELL(PRTLN,'(PRTLN#6))
- DO PRT2
- +10 IF $DATA(PSJPSTO)
- SET PST=PSJPSTO
- KILL PSJPSTO
- +11 QUIT
- PRT2 ;
- +1 IF PSGMAROC>5
- IF (TS/6>7)
- Begin DoDot:1
- +2 SET MSG1="*** CONTINUE ON NEXT PAGE ***"
- +3 DO BOT
- DO HEADER
- End DoDot:1
- +4 IF PRTLN#6=0
- if PSGMAROC<6
- WRITE !?7,LN2
- if PRTLN'=MARLB
- SET PSGMAROC=PSGMAROC+1
- +5 QUIT
- CHKLAB ; Check to see if next label is needed.
- +1 IF '((L+1)#6)
- WRITE ?48,"| ",$GET(TS(L))
- DO CELL(L,0)
- WRITE !?1,"See next label for continuation",?48,"| ",$GET(TS(L+1))
- DO CELL(L+1,1)
- if PSGMAROC<6
- WRITE !?7,LN2,!?1
- SET L=L+2
- SET PSGMAROC=PSGMAROC+1
- Begin DoDot:1
- +2 IF PSGMAROC>5
- IF (TS/6>7)
- SET MSG1="*** CONTINUE ON NEXT PAGE ***"
- DO BOT
- DO HEADER
- End DoDot:1
- QUIT
- +3 IF '$TEST
- WRITE ?48,"| ",$GET(TS(L))
- DO CELL(L,0)
- WRITE !?1
- SET L=L+1
- +4 QUIT
- INIT ; Print the initials on the label.
- +1 WRITE !?1,$EXTRACT("WS",1,PSGLWS*2),?4,$SELECT(PSGLSM:$EXTRACT("HSM",PSGLSM,3),1:""),?8,$EXTRACT("NF",1,PSGLNF*2),?30,"RPH: ",PSGLRPH,?39," RN: ",PSGLRN,?48,"| ",?50,$GET(TS(L))
- DO CELL(L,1)
- +2 QUIT
- CELL(X,X1) ; Print the **** on the not to be given cells.
- +1 NEW QTS,CELL
- SET CELL=$EXTRACT($SELECT(X1:" ",1:"_________"),1,PSGMARDF=7*5+4)
- +2 IF PST["CZ"
- IF (X=6)
- NEW PSGLFFD,PSGMARGD
- SET P(9)=""
- SET PSGLFFD="9999999"
- SET PSGMARGD=""
- WRITE ?55
- DO ASTERS
- QUIT
- +3 IF TS=1
- IF 'PSGMARTS
- IF (X=6)
- WRITE ?55
- SET P(9)=1
- DO ASTERS
- KILL P(9)
- QUIT
- +4 IF $GET(TS(X))=""
- WRITE ?55,$SELECT(X1:LN7,1:LN4)
- QUIT
- +5 FOR Q=0:0
- SET Q=$ORDER(PSGD(Q))
- if 'Q
- QUIT
- SET QTS=Q_"."_TS(X)
- WRITE ?55,"|"_$SELECT(QTS<PSGLSSD:EXPIRE,QTS'<PSGLFFD:EXPIRE,PSGMARGD="":ASTERS,$GET(ONHOLD):$EXTRACT("Hold ",1,$LENGTH(CELL)),PSGMARGD[$PIECE(PSGD(Q),"^"):CELL,1:ASTERS)
- +6 WRITE "|"
- +7 QUIT
- ASTERS ; Print the **** on the first label.
- +1 IF ONHOLD
- NEW HSPACE
- SET HSPACE=SPACES
- SET SPACES=$EXTRACT("Hold ",1,$LENGTH(HSPACE))
- +2 SET PSGLFFD=$PIECE(PSGLFFD,".")
- FOR Q=0:0
- SET Q=$ORDER(PSGD(Q))
- if 'Q
- QUIT
- WRITE "|"_$SELECT(Q<$PIECE(PSGLSSD,"."):ASTERS,Q=PSGLFFD:EXPIRE,Q>PSGLFFD:ASTERS,(PSGMARGD=""&($GET(P(9))="")):SPACES,PSGMARGD[$PIECE(PSGD(Q),"^"):SPACES,1:ASTERS)
- +3 WRITE "|"
- +4 IF ONHOLD
- SET SPACES=HSPACE
- +5 QUIT
- BOT ; bottom of MAR
- +1 IF MSG1]""
- FOR QQ=1:1:6
- WRITE !
- if QQ=1
- WRITE ?6,"|",?19,"|"
- if 34[QQ
- WRITE ?12,$SELECT(QQ=3:MSG1,1:MSG2)
- WRITE ?55,$SELECT(QQ<6:LN4,1:LN7)
- +2 IF PSGMAROC<6
- SET PSGMAROC=6-PSGMAROC
- FOR Q=1:1:PSGMAROC
- FOR QQ=1:1:6
- WRITE !
- if QQ=1
- WRITE ?6,"|",?19,"|"
- if 34[QQ
- WRITE ?12,$SELECT(QQ=3:MSG1,1:MSG2)
- WRITE ?55,$SELECT(QQ<6:LN4,1:LN7)
- IF QQ=6
- IF Q<PSGMAROC
- WRITE !?7,LN2
- ENB ;
- +1 IF $DATA(PSGMPG)
- SET PSGMPG=PSGMPG+1
- SET PSGMPGN=$SELECT(PSGMPGN'["LAST":"PAGE: ",1:PSGMPGN)_PSGMPG
- +2 WRITE !,LN1
- +3 WRITE !,"|",?11,"SIGNATURE/TITLE",?38,"| INIT | INJECTION SITES |",?87,"MED/DOSE OMITTED",?107,"| REASON | INIT |"
- +4 FOR Q=1:1:10
- WRITE !,"|"_$EXTRACT(LN1,1,37)_"|------|"_BLN(Q),?82,"|"_$EXTRACT(LN1,1,24)_"|"_$EXTRACT(LN1,1,16)_"|------|"
- +5 WRITE !,LN1,!?3,PPN,?45,PSSN,?58,"Room-Bed: "_$SELECT(PWDN'["C!":PRB,1:""),?100,$SELECT($DATA(PSGMPG):PSGMPGN,1:""),?116,"VA FORM 10-2970",*13
- +6 QUIT
- SITE(LEN) ;* Get the Institution name
- +1 ;* Input : LEN = Report width (80 or 132 column)
- +2 ;* Output: space needed to center text ^ VAMC name
- +3 NEW X
- +4 SET X=$$NAME^VASITE
- +5 IF X=""
- SET X=$$SITE^VASITE
- if X]""
- SET X="VAMC: "_$PIECE(X,U,2)_" ("_$PIECE(X,U,3)_")"
- +6 IF X=""
- QUIT ""
- +7 QUIT (LEN-$LENGTH(X))/2_U_X
- ONHOLD ;Check order to see if it's ON hold, set Flag True if it is
- +1 SET ONHOLD=0
- +2 NEW PSGON
- +3 SET PSGON=+ON
- +4 ;If unit dose order, check Hold Status field = Active Hold
- +5 IF (ON["A")!(ON["O")!(ON["U")
- IF $PIECE($GET(^PS(55,$PIECE(PN,"^",2),5,PSGON,0)),"^",9)="H"
- SET ONHOLD=1
- QUIT
- +6 ;If IV Order, check Status field = Hold
- +7 IF ON["V"
- IF $PIECE($GET(^PS(55,$PIECE(PN,"^",2),"IV",PSGON,0)),"^",17)="H"
- SET ONHOLD=1
- QUIT
- +8 QUIT