- PSGMMIVC ;BIR/MV-PRT MULT DAYS MAR C ORDERS(IV) ;16 Mar 99 / 2:10 PM
- ;;5.0;INPATIENT MEDICATIONS;**20,21,28,31,35,67,58,110,267**;16 DEC 97;Build 158
- ;
- ; Reference to ^PS(52.7 supported by DBIA #2173.
- ; Reference to ^PS(55 supported by DBIA #2191.
- ;
- PRT ;*** Print IV orders.
- K P,DRG,PSGLRN,PSGMARTS,PSGMARGD,PSGLFFD,TS N ON55,PSJLABEL S TS=1,PSGMARGD="",PSJLABEL=1
- S ON=$P(DAO,U,2),DFN=$P(PN,U,2) D:$P(DAO,U,2)["V" GT55^PSIVORFB D:$P(DAO,U,2)["P" GT531^PSIVORFA(DFN,ON) D:P(9)]"" OS S PSGLSSD=P(2),PSGLFFD=P(3)
- I $G(P("DTYP"))'=1 K P(11)
- F X="LOG",2,3 S:P(X) P(X)=$$ENDTC1^PSGMI(P(X))
- D INITOPI
- S PSGST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I PSGST'="O" S PSGST=$S(P(9)["PRN":"P",1:"C")
- I PSGST="O",(P(2)="") S PSGST=""
- NEW NAMENEED,NEED,X S NAMENEED=0
- D LNNEED^PSGMIV,PRTIV
- Q
- ;
- OS ; order record set
- S FD=P(3),PSGOES="",X=P(9),SD=P(2) D EN^PSGS0 S T=PSGS0XT
- S QQ="" I PST["C" D DTS^PSGMMAR0(P(9)) S SD=$P(SD,"."),QQ="" F X=0:0 S X=$O(PSGD(X)) Q:'X S QQ=QQ_$S(X<SD:"",X>FD:"",'S:$P(PSGD(X),U),$D(S(X)):$P(PSGD(X),U),1:"")
- I T="D",P(11)="" S P(11)=$E($P(P(2),".",2)_"0000",1,4)
- S PSGMARTS=P(11),PSGMARGD=QQ
- K TS D TS^PSGMAR3(P(11))
- Q
- ;
- PRTIV ;*** Print IV order on MAR
- I PSGMAROC,(PSGMAROC+LN)>6 D BOT^PSGMMAR2,HEADER^PSGMMAR2
- S PSGMAROC=PSGMAROC+1 W !?6,"|",?19,"|",?48,"|",$G(TS(1)) D CELL(1,0)
- W !,$E(P("LOG"),1,5)," |"
- W:ON["V" $E(P(2),1,5)_$E(P(2),9,14)," |",P(3)
- W:ON["P" "P E N D I N G"
- W ?39,"("_$E(PSGP(0))_$E(PSSN,8,12)_")"
- W ?48,"|",$G(TS(2)) D CELL(2,0) S L=3
- NEW NAME
- F X=0:0 S X=$O(DRG("AD",X)) Q:'X D NAME^PSIVUTL(DRG("AD",X),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y W !,NAME(Y) W:L=3 ?47,PSGST W ?48,"|",$G(TS(L)) D CELL(L,'(L#6)) D L(1)
- I '$G(DRG("AD",0)) D
- .W !
- .W:L=3 ?47,PSGST W ?48,"|",$G(TS(L)) D CELL(L,'(L#6)) D L(1)
- W:$G(DRG("SOL",0)) !,"in "
- NEW PSJPRT2
- F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D NAME^PSIVUTL(DRG("SOL",X),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y D
- . W:(Y>1!(X>1)) ! W ?4,NAME(Y) W:L=3 ?47,PSGST W ?48,"|",$G(TS(L)) D CELL(L,'(L#6)) D L(1)
- . S PSJPRT2=$P(^PS(52.7,+DRG("SOL",X),0),U,4) I PSJPRT2]"" W !?7,PSJPRT2 W:L=3 ?47,PSGST W ?48,"|",$G(TS(L)) D CELL(L,'(L#6)) D L(1)
- W !,$P(P("MR"),U,2)," ",P(9)," ",P(8) W ?48,"|",$G(TS(L)) D CELL(L,'(L#6)) I L>5 S PSJTMPL=L\6,PSJDIV=PSJTMPL+4 I L>PSJDIV,(L#PSJDIV>1) W ! ;I L>5,(L#5>1) W !
- I '$G(DRG("SOL",0)) S L=L+1 W !,?48,"|",$G(TS(L)) D CELL(L,'(L#6))
- I P(4)="C",'(L#5),P("OPI")="" D
- . D L(1)
- . W !,"*CAUTION-CHEMOTHERAPY*",?48,"|",$G(TS(L))
- . D CELL(L,'(L#6)) W ! ;S L=L+1
- E I P(4)="C" D
- . D L(1)
- . W:L#7=0 !
- . W "*CAUTION-CHEMOTHERAPY*",?48,"|",$G(TS(L))
- . D CELL(L,'(L#6))
- . I (L+1)#6'=0 W !
- I (L#5)=0,($L($P(P("OPI"),"^"))<29),(TS<7) S L=L+1
- E D L(1)
- W:P("OPI")=""&(TS>6) !
- I P("OPI")'="",'$$OPI^PSGMIV(PSGP,ON55) D
- . I L#7=0 W !
- . I L#5=1 W !
- . N PSJTMPX S PSJTMPX=0
- . F Y=1:1:$L($P(P("OPI"),"^")," ") S Y1=$P($P(P("OPI"),"^")," ",Y) D
- .. I $L(Y1)>47 W $E(Y1,1,47)
- .. I (PSJTMPX+$L(Y1))>47 W ?48,"|",$G(TS(L)) D CELL(L,'(L#6)),L(1) S PSJTMPX=0 W !
- .. I $L(Y1)>47 W $E(Y1,48,$L(Y1)) S PSJTMPX=$L($E(Y1,48,$L(Y1)))
- .. E W Y1," " S PSJTMPX=PSJTMPX+$L(Y1)+1
- N PSGIVFL I '$O(DRG("AD",0))!'$O(DRG("SOL",0)) S PSGIVFL=1
- I L>TS,(L#6) W ?48,"|",$G(TS(L)) D CELL(L,'(L#6)) S L=L+1
- I (TS-1)>L W ?48,"|",$G(TS(L)) D CELL(L,'(L#6)) D
- . F L=L+1:1:TS-1 D L(0) W !?48,"|",$G(TS(L)) D CELL(L,'(L#6))
- . S L=L+1
- F Q:'(L#6) W !?48,"|",$G(TS(L)) D CELL(L,'(L#6)) S L=L+1
- I '(L#6),(P("OPI")="") W !
- I P("OPI")]"",(L>6) W !
- W ?29,"RPH: ",PSGLRPH,?38,"RN: ",PSGLRN,?48,"|",$G(TS(L)) D CELL(L,'(L#6)) W:PSGMAROC<6 !?7,LN2
- Q
- ;
- L(X) ;***Check to see if a new block if needed.
- S L=L+X
- I L#6=0,PSGMAROC<6 D
- . W !,"See next label for continuation",?48,"|",$G(TS(L)) D CELL(L,'(L#6))
- . W:PSGMAROC<6 !?7,LN2,$C(13) S $X=0 S PSGMAROC=PSGMAROC+1,L=L+1 D
- . . I LN>6,(PSGMAROC>5) S MSG1="*** CONTINUE ON NEXT PAGE ***" D BOT^PSGMMAR2,HEADER^PSGMMAR2 S PSGMAROC=1
- Q
- LN(L) ;*** Print lines within block.
- N X S X=$S(L#6:LN4,1:LN7)
- Q X
- CELL(X,X1) ;
- I ON["P",(X=6) NEW PSGLFFD,PSGMARGD S P(9)="",PSGLFFD="9999999",PSGMARGD="" W ?55 D ASTERS^PSGMMAR2 Q
- I TS=1,'$G(P(11)),(X=6) W ?55 D ASTERS^PSGMMAR2 Q
- I TS=1,'$G(P(11)) W ?55,$$LN(X) Q
- D CELL^PSGMMAR2(X,X1)
- Q
- INITOPI ;* Set nurse's initial and the other print info.
- D RPHINIT^PSGMIV(.PSGLRPH)
- S PSGLRN="_____"
- I ON["V" N ND4 S ND4=$G(^PS(55,DFN,"IV",+ON,4))
- I $G(ND4) D
- .I $G(DFN),$G(ON) N PSGLREN S PSGLREN=+$$LASTREN^PSJLMPRI(DFN,ON) D
- ..N PSGLRNDT S PSGLRNDT=$P(ND4,"^",2),ND4=+ND4 I PSGLRNDT,$G(PSGLREN) I $G(PSGLREN)>PSGLRNDT S ND4=0
- .I ND4 D NAME(+ND4,"",.PSGLRN)
- I ON["P" D
- . I P("OPI")="",$O(^PS(53.1,ON,12,0)) S X=0 F S X=$O(^PS(53.1,ON,12,X)) Q:'X S Z=$G(^(X,0)),Y=$L(P("OPI")) S:Y+$L(Z)'>179 P("OPI")=P("OPI")_Z_" " I Y+$L(Z)>179 S P("OPI")="SEE PROVIDER COMMENTS"
- . S PSGST=""
- . D NAME(+$G(^PS(53.1,+ON,4)),"",.PSGLRN)
- Q
- NAME(X,NAME,INIT) ;Lookup in ^VA(200.
- ;X = IEN in ^VA(200
- ;NAME = Return the name in 200
- ;INIT = Return the initial
- NEW DIC,Y
- S DIC="^VA(200,",DIC(0)="NZ" D ^DIC
- S NAME=$G(Y(0,0))
- S INIT=$P($G(Y(0)),U,2)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMMIVC 5183 printed Jan 18, 2025@03:02:56 Page 2
- PSGMMIVC ;BIR/MV-PRT MULT DAYS MAR C ORDERS(IV) ;16 Mar 99 / 2:10 PM
- +1 ;;5.0;INPATIENT MEDICATIONS;**20,21,28,31,35,67,58,110,267**;16 DEC 97;Build 158
- +2 ;
- +3 ; Reference to ^PS(52.7 supported by DBIA #2173.
- +4 ; Reference to ^PS(55 supported by DBIA #2191.
- +5 ;
- PRT ;*** Print IV orders.
- +1 KILL P,DRG,PSGLRN,PSGMARTS,PSGMARGD,PSGLFFD,TS
- NEW ON55,PSJLABEL
- SET TS=1
- SET PSGMARGD=""
- SET PSJLABEL=1
- +2 SET ON=$PIECE(DAO,U,2)
- SET DFN=$PIECE(PN,U,2)
- if $PIECE(DAO,U,2)["V"
- DO GT55^PSIVORFB
- if $PIECE(DAO,U,2)["P"
- DO GT531^PSIVORFA(DFN,ON)
- if P(9)]""
- DO OS
- SET PSGLSSD=P(2)
- SET PSGLFFD=P(3)
- +3 IF $GET(P("DTYP"))'=1
- KILL P(11)
- +4 FOR X="LOG",2,3
- if P(X)
- SET P(X)=$$ENDTC1^PSGMI(P(X))
- +5 DO INITOPI
- +6 SET PSGST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
- IF PSGST'="O"
- SET PSGST=$SELECT(P(9)["PRN":"P",1:"C")
- +7 IF PSGST="O"
- IF (P(2)="")
- SET PSGST=""
- +8 NEW NAMENEED,NEED,X
- SET NAMENEED=0
- +9 DO LNNEED^PSGMIV
- DO PRTIV
- +10 QUIT
- +11 ;
- OS ; order record set
- +1 SET FD=P(3)
- SET PSGOES=""
- SET X=P(9)
- SET SD=P(2)
- DO EN^PSGS0
- SET T=PSGS0XT
- +2 SET QQ=""
- IF PST["C"
- DO DTS^PSGMMAR0(P(9))
- SET SD=$PIECE(SD,".")
- SET QQ=""
- FOR X=0:0
- SET X=$ORDER(PSGD(X))
- if 'X
- QUIT
- SET QQ=QQ_$SELECT(X<SD:"",X>FD:"",'S:$PIECE(PSGD(X),U),$DATA(S(X)):$PIECE(PSGD(X),U),1:"")
- +3 IF T="D"
- IF P(11)=""
- SET P(11)=$EXTRACT($PIECE(P(2),".",2)_"0000",1,4)
- +4 SET PSGMARTS=P(11)
- SET PSGMARGD=QQ
- +5 KILL TS
- DO TS^PSGMAR3(P(11))
- +6 QUIT
- +7 ;
- PRTIV ;*** Print IV order on MAR
- +1 IF PSGMAROC
- IF (PSGMAROC+LN)>6
- DO BOT^PSGMMAR2
- DO HEADER^PSGMMAR2
- +2 SET PSGMAROC=PSGMAROC+1
- WRITE !?6,"|",?19,"|",?48,"|",$GET(TS(1))
- DO CELL(1,0)
- +3 WRITE !,$EXTRACT(P("LOG"),1,5)," |"
- +4 if ON["V"
- WRITE $EXTRACT(P(2),1,5)_$EXTRACT(P(2),9,14)," |",P(3)
- +5 if ON["P"
- WRITE "P E N D I N G"
- +6 WRITE ?39,"("_$EXTRACT(PSGP(0))_$EXTRACT(PSSN,8,12)_")"
- +7 WRITE ?48,"|",$GET(TS(2))
- DO CELL(2,0)
- SET L=3
- +8 NEW NAME
- +9 FOR X=0:0
- SET X=$ORDER(DRG("AD",X))
- if 'X
- QUIT
- DO NAME^PSIVUTL(DRG("AD",X),47,.NAME,1)
- FOR Y=0:0
- SET Y=$ORDER(NAME(Y))
- if 'Y
- QUIT
- WRITE !,NAME(Y)
- if L=3
- WRITE ?47,PSGST
- WRITE ?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- DO L(1)
- +10 IF '$GET(DRG("AD",0))
- Begin DoDot:1
- +11 WRITE !
- +12 if L=3
- WRITE ?47,PSGST
- WRITE ?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- DO L(1)
- End DoDot:1
- +13 if $GET(DRG("SOL",0))
- WRITE !,"in "
- +14 NEW PSJPRT2
- +15 FOR X=0:0
- SET X=$ORDER(DRG("SOL",X))
- if 'X
- QUIT
- DO NAME^PSIVUTL(DRG("SOL",X),47,.NAME,1)
- FOR Y=0:0
- SET Y=$ORDER(NAME(Y))
- if 'Y
- QUIT
- Begin DoDot:1
- +16 if (Y>1!(X>1))
- WRITE !
- WRITE ?4,NAME(Y)
- if L=3
- WRITE ?47,PSGST
- WRITE ?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- DO L(1)
- +17 SET PSJPRT2=$PIECE(^PS(52.7,+DRG("SOL",X),0),U,4)
- IF PSJPRT2]""
- WRITE !?7,PSJPRT2
- if L=3
- WRITE ?47,PSGST
- WRITE ?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- DO L(1)
- End DoDot:1
- +18 ;I L>5,(L#5>1) W !
- WRITE !,$PIECE(P("MR"),U,2)," ",P(9)," ",P(8)
- WRITE ?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- IF L>5
- SET PSJTMPL=L\6
- SET PSJDIV=PSJTMPL+4
- IF L>PSJDIV
- IF (L#PSJDIV>1)
- WRITE !
- +19 IF '$GET(DRG("SOL",0))
- SET L=L+1
- WRITE !,?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- +20 IF P(4)="C"
- IF '(L#5)
- IF P("OPI")=""
- Begin DoDot:1
- +21 DO L(1)
- +22 WRITE !,"*CAUTION-CHEMOTHERAPY*",?48,"|",$GET(TS(L))
- +23 ;S L=L+1
- DO CELL(L,'(L#6))
- WRITE !
- End DoDot:1
- +24 IF '$TEST
- IF P(4)="C"
- Begin DoDot:1
- +25 DO L(1)
- +26 if L#7=0
- WRITE !
- +27 WRITE "*CAUTION-CHEMOTHERAPY*",?48,"|",$GET(TS(L))
- +28 DO CELL(L,'(L#6))
- +29 IF (L+1)#6'=0
- WRITE !
- End DoDot:1
- +30 IF (L#5)=0
- IF ($LENGTH($PIECE(P("OPI"),"^"))<29)
- IF (TS<7)
- SET L=L+1
- +31 IF '$TEST
- DO L(1)
- +32 if P("OPI")=""&(TS>6)
- WRITE !
- +33 IF P("OPI")'=""
- IF '$$OPI^PSGMIV(PSGP,ON55)
- Begin DoDot:1
- +34 IF L#7=0
- WRITE !
- +35 IF L#5=1
- WRITE !
- +36 NEW PSJTMPX
- SET PSJTMPX=0
- +37 FOR Y=1:1:$LENGTH($PIECE(P("OPI"),"^")," ")
- SET Y1=$PIECE($PIECE(P("OPI"),"^")," ",Y)
- Begin DoDot:2
- +38 IF $LENGTH(Y1)>47
- WRITE $EXTRACT(Y1,1,47)
- +39 IF (PSJTMPX+$LENGTH(Y1))>47
- WRITE ?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- DO L(1)
- SET PSJTMPX=0
- WRITE !
- +40 IF $LENGTH(Y1)>47
- WRITE $EXTRACT(Y1,48,$LENGTH(Y1))
- SET PSJTMPX=$LENGTH($EXTRACT(Y1,48,$LENGTH(Y1)))
- +41 IF '$TEST
- WRITE Y1," "
- SET PSJTMPX=PSJTMPX+$LENGTH(Y1)+1
- End DoDot:2
- End DoDot:1
- +42 NEW PSGIVFL
- IF '$ORDER(DRG("AD",0))!'$ORDER(DRG("SOL",0))
- SET PSGIVFL=1
- +43 IF L>TS
- IF (L#6)
- WRITE ?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- SET L=L+1
- +44 IF (TS-1)>L
- WRITE ?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- Begin DoDot:1
- +45 FOR L=L+1:1:TS-1
- DO L(0)
- WRITE !?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- +46 SET L=L+1
- End DoDot:1
- +47 FOR
- if '(L#6)
- QUIT
- WRITE !?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- SET L=L+1
- +48 IF '(L#6)
- IF (P("OPI")="")
- WRITE !
- +49 IF P("OPI")]""
- IF (L>6)
- WRITE !
- +50 WRITE ?29,"RPH: ",PSGLRPH,?38,"RN: ",PSGLRN,?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- if PSGMAROC<6
- WRITE !?7,LN2
- +51 QUIT
- +52 ;
- L(X) ;***Check to see if a new block if needed.
- +1 SET L=L+X
- +2 IF L#6=0
- IF PSGMAROC<6
- Begin DoDot:1
- +3 WRITE !,"See next label for continuation",?48,"|",$GET(TS(L))
- DO CELL(L,'(L#6))
- +4 if PSGMAROC<6
- WRITE !?7,LN2,$CHAR(13)
- SET $X=0
- SET PSGMAROC=PSGMAROC+1
- SET L=L+1
- Begin DoDot:2
- +5 IF LN>6
- IF (PSGMAROC>5)
- SET MSG1="*** CONTINUE ON NEXT PAGE ***"
- DO BOT^PSGMMAR2
- DO HEADER^PSGMMAR2
- SET PSGMAROC=1
- End DoDot:2
- End DoDot:1
- +6 QUIT
- LN(L) ;*** Print lines within block.
- +1 NEW X
- SET X=$SELECT(L#6:LN4,1:LN7)
- +2 QUIT X
- CELL(X,X1) ;
- +1 IF ON["P"
- IF (X=6)
- NEW PSGLFFD,PSGMARGD
- SET P(9)=""
- SET PSGLFFD="9999999"
- SET PSGMARGD=""
- WRITE ?55
- DO ASTERS^PSGMMAR2
- QUIT
- +2 IF TS=1
- IF '$GET(P(11))
- IF (X=6)
- WRITE ?55
- DO ASTERS^PSGMMAR2
- QUIT
- +3 IF TS=1
- IF '$GET(P(11))
- WRITE ?55,$$LN(X)
- QUIT
- +4 DO CELL^PSGMMAR2(X,X1)
- +5 QUIT
- INITOPI ;* Set nurse's initial and the other print info.
- +1 DO RPHINIT^PSGMIV(.PSGLRPH)
- +2 SET PSGLRN="_____"
- +3 IF ON["V"
- NEW ND4
- SET ND4=$GET(^PS(55,DFN,"IV",+ON,4))
- +4 IF $GET(ND4)
- Begin DoDot:1
- +5 IF $GET(DFN)
- IF $GET(ON)
- NEW PSGLREN
- SET PSGLREN=+$$LASTREN^PSJLMPRI(DFN,ON)
- Begin DoDot:2
- +6 NEW PSGLRNDT
- SET PSGLRNDT=$PIECE(ND4,"^",2)
- SET ND4=+ND4
- IF PSGLRNDT
- IF $GET(PSGLREN)
- IF $GET(PSGLREN)>PSGLRNDT
- SET ND4=0
- End DoDot:2
- +7 IF ND4
- DO NAME(+ND4,"",.PSGLRN)
- End DoDot:1
- +8 IF ON["P"
- Begin DoDot:1
- +9 IF P("OPI")=""
- IF $ORDER(^PS(53.1,ON,12,0))
- SET X=0
- FOR
- SET X=$ORDER(^PS(53.1,ON,12,X))
- if 'X
- QUIT
- SET Z=$GET(^(X,0))
- SET Y=$LENGTH(P("OPI"))
- if Y+$LENGTH(Z)'>179
- SET P("OPI")=P("OPI")_Z_" "
- IF Y+$LENGTH(Z)>179
- SET P("OPI")="SEE PROVIDER COMMENTS"
- +10 SET PSGST=""
- +11 DO NAME(+$GET(^PS(53.1,+ON,4)),"",.PSGLRN)
- End DoDot:1
- +12 QUIT
- NAME(X,NAME,INIT) ;Lookup in ^VA(200.
- +1 ;X = IEN in ^VA(200
- +2 ;NAME = Return the name in 200
- +3 ;INIT = Return the initial
- +4 NEW DIC,Y
- +5 SET DIC="^VA(200,"
- SET DIC(0)="NZ"
- DO ^DIC
- +6 SET NAME=$GET(Y(0,0))
- +7 SET INIT=$PIECE($GET(Y(0)),U,2)
- +8 QUIT