- PSGMIV ;BIR/MV-IV ORDER FOR THE 24 HOUR MAR. ;25 Nov 98 / 9:07 AM
- ;;5.0;INPATIENT MEDICATIONS;**4,20,21,28,58,111,131,145,267,275**;16 DEC 97;Build 157
- ;
- ; Reference to ^PS(55 supported by DBIA #2191.
- ; Reference to ^PS(52.7 supported by DBIA #2173.
- ;
- START ;*** Read IV orders
- S ON=""
- F PSGMARED=PSGPLS-.0001:0 S PSGMARED=$O(^PS(55,PSGP,"IV","AIT",PST,PSGMARED)) Q:'PSGMARED F S ON=$O(^PS(55,PSGP,"IV","AIT",PST,PSGMARED,ON)) Q:ON="" D IV
- Q
- IV ;*** Sort IV orders for 24 Hrs MAR.
- K DRG,P N X,ON55,PSJLABEL S DFN=PSGP,PSJLABEL=1 D GT55^PSIVORFB
- Q:P(2)>PSGPLF
- S X=$P(P("MR"),U,2) Q:XTYPE=2&(X["IV") Q:XTYPE=3&(PST="S")&'($S(X="IV":1,X="IVPB":1,1:0))
- S QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
- S QST=$S(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE
- N PSGMARWC ;DEM (05/30/2006) - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
- S PSGMARWC=PSGMARWN
- I $G(DRG) S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),X=$E($P(X,U,2),1,20)_U_ON_"V" D
- . N A
- . S A=$G(^PS(55,PSGP,"IV",+ON,"DSS")) I $P(A,"^")]"" S PSGMARWN="C!"_$P(A,"^") I $G(SUB1)]"",$G(SUB2)]"",'$D(^TMP($J,TM,PSGMARWN,SUB1,SUB2)) D
- . . N X,X1,Y
- . . D SPN^PSGMAR0
- . . Q
- . I PSGSS="P"!(PSGSS="C")!(PSGSS="L") S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q
- . S:PSGRBPPN="P" ^TMP($J,TM,PSGMARWN,PPN,PSJPRB,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
- . S:PSGRBPPN="R" ^TMP($J,TM,PSGMARWN,PSJPRB,PPN,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
- S:PSGMARWN'=PSGMARWC PSGMARWN=PSGMARWC
- Q
- PRT ;*** Print IV orders.
- K TS,P,DRG NEW ON55,LN,PSJLABEL S PSJLABEL=1
- S ON=$P(DAO,U,2),DFN=$P(PN,U,2) D:ON["V" GT55^PSIVORFB
- D:ON["P" GT531^PSIVORFA(DFN,ON)
- S TS=1,TMSTR="" I P(9)]"" D ORSET,TS^PSGMAR3(P(11))
- F X="LOG",2,3 S:P(X) P(X)=$$ENDTC1^PSGMI(P(X))
- S PSGST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I PSGST'="O" S PSGST=$S(P(9)["PRN":"P",1:"C")
- S PSGLFFD=PSGPLF
- D INITOPI^PSGMMIVC
- NEW NAMENEED,NEED,X S NAMENEED=0
- D LNNEED,PRTIV
- Q
- LNNEED ;*** Find lines needed per label.
- ;*** If OPI<29 char, it is ok to put INITs in the same line.
- ;*** Add number of lines needed for additives and solutions and 1 line
- ;*** for infusion rate and x line for OPI. Divide by 5 to determine
- ;*** of label(s) needed for this order.
- F X="AD","SOL" D NAMENEED^PSJMUTL(X,47,.NEED) S NAMENEED=NAMENEED+NEED
- N OPILEN,OPILAST S OPILAST=$S(($G(ON55)["V"):$O(^PS(55,DFN,"IV",ON55,10," "),-1),1:"") S OPILEN=$S(OPILAST:(74*OPILAST),1:$L(P("OPI")))
- S X=(OPILEN\47)+((OPILEN#47)>28)+1+($P(P("OPI"),"^")]""&(P(4)="C"))
- S X=(NAMENEED+X+2) S X=$S(X<6:1,1:((X-6)\5)+2)
- S LN=$S(TS/6>X:TS/6,1:X)
- Q
- ;
- OS ; order record set
- Q
- ;
- PRTIV ;*** Print IV order on MAR
- D ONHOLD^PSGMMAR2
- I PSGMAROC,(PSGMAROC+LN)>6 D BOT^PSGMAR3,HEADER^PSGMAR3
- NEW PSGL S PSGL="|"
- S PSGMAROC=PSGMAROC+1 W !?6,"|",?19,"|",?48,PSGL,$G(TS(1)),?55,"|"
- W !,$E(P("LOG"),1,5)," |"
- I ON["V" D
- . I $G(ONHOLD) W "O N H O L D" Q
- . W $E(P(2),1,5)_$E(P(2),9,14)," |",P(3)
- . Q
- W:ON["P" "P E N D I N G"
- W ?39,"(",$E(PSGP(0))_$E(PSSN,8,12)_")"
- W ?48,PSGL,$G(TS(2)),?55,"|" S L=3
- NEW NAME,PSIVX
- F PSIVX=0:0 S PSIVX=$O(DRG("AD",PSIVX)) Q:'PSIVX D NAME^PSIVUTL(DRG("AD",PSIVX),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y W !,NAME(Y) W:L=3 ?47,PSGST W ?48,PSGL,$G(TS(L)),?55,"|" D:(PSIVX=1&((PSGST="O")!(PSGST="C"))) TMSTR^PSGMAR3 D L(1)
- W:$G(DRG("SOL",0)) !,"in "
- NEW PSJPRT2
- F PSIVX=0:0 S PSIVX=$O(DRG("SOL",PSIVX)) Q:'PSIVX D NAME^PSIVUTL(DRG("SOL",PSIVX),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y D
- . W:(Y>1!(PSIVX>1)) ! W ?4,NAME(Y) W:L=3 ?47,PSGST W ?48,PSGL,$G(TS(L)),?55,"|" D:L=3 TMSTR^PSGMAR3 D L(1)
- . S PSJPRT2=$P(^PS(52.7,+DRG("SOL",PSIVX),0),U,4) I PSJPRT2]"" W !?7,PSJPRT2 W:L=3 ?47,PSGST W ?48,PSGL,$G(TS(L)),?55,"|" D:L=3 TMSTR^PSGMAR3 D L(1)
- W !,$P(P("MR"),U,2)," ",P(9)," ",P(8) W ?48,PSGL,$G(TS(L)),?55,"|" I L>5,(L#5) W !
- I '$O(DRG("AD",0))!('$O(DRG("SOL",0))) W !?48,PSGL,$G(TS(L)),?55,"|" S L=5
- I P(4)="C",'(L#5),P("OPI")="" W !,"*CAUTION-CHEMOTHERAPY*" S L=L+1 Q
- I P(4)="C" D L(1) W !,"*CAUTION-CHEMOTHERAPY*",?48,PSGL,$G(TS(L)),?55,"|"
- 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")'="" I '$$OPI(PSGP,ON55) D
- . W:(L#6)=1 !
- . F Y=1:1:$L($P(P("OPI"),"^")," ") S Y1=$P($P(P("OPI"),"^")," ",Y) D W Y1," "
- . I ($X+$L(Y1))>47 W ?48,PSGL,$G(TS(L)),?55,"|" D L(1) W !
- I L>TS,(L#6) W ?48,PSGL,$G(TS(L)),?55,"|" S L=L+1 W:L#6=0 !
- I (TS-1)>L W ?48,PSGL,$G(TS(L)),?55,"|" D
- . F L=L+1:1:TS-1 D L(0) W !?48,PSGL,$G(TS(L)),?55,"|"
- . S L=L+1
- F Q:'(L#6) W !?48,PSGL,$G(TS(L)),?55,"|" S L=L+1
- I '(L#6),(P("OPI")="") W !
- I P("OPI")]"",(L>6) W !
- W ?29,"RPH: ",PSGLRPH,?38,"RN: ",PSGLRN,?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2
- Q
- ;
- OPI(DFN,ORDER,OPITEXT,OPIPRINT) ; Retrieve, format, and print Other Print Info
- N TXTLN S TXTLN=$$GETSIOPI^PSJBCMA5($G(DFN),$G(ORDER),1) I 'TXTLN Q 0
- N TXTLN,TXT,I,TMPMARX,MARXTXT,LAST,II,Y K MARX S LAST=0,TMPMARX="" S PSGL=$S(($G(PSGL)]""):PSGL,1:"|")
- I ORDER["V" S TXTLN=0 F I=1:1 S TXTLN=$O(^PS(55,DFN,"IV",+ORDER,10,TXTLN)) Q:'TXTLN D
- .S MARXTXT=^PS(55,DFN,"IV",+ORDER,10,TXTLN,0) D TXT^PSGMUTL(MARXTXT,47) S LAST=$O(TMPMARX(" "),-1) S II=0 F S II=$O(MARX(II)) Q:'II S TMPMARX(LAST+II)=MARX(II)
- I ORDER["P" S TXTLN=0 F I=1:1 S TXTLN=$O(^PS(53.1,+ORDER,16,TXTLN)) Q:'TXTLN D
- .S MARXTXT=^PS(53.1,+ORDER,16,TXTLN,0) D TXT^PSGMUTL(MARXTXT,47) S LAST=$O(TMPMARX(" "),-1) S II=0 F S II=$O(MARX(II)) Q:'II S TMPMARX(LAST+II)=MARX(II)
- I $G(OPIPRINT) K MARX M MARX=TMPMARX S I=0 F S I=$O(MARX(I)) Q:'I D
- . W:(L#6)=0 !
- . S Y1=MARX(I) W Y1," ",?48,PSGL,$G(TS(L)),?55,"|" D L(1) W !
- I $G(OPITEXT) M OPITEXT=TMPMARX
- Q 1
- L(X) ;***Check to see if a new block is needed.
- S L=L+X
- I L#6=0,PSGMAROC<6 W !,"See next label for continuation",?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2 S PSGMAROC=PSGMAROC+1,L=L+1 D
- .I LN>6,(PSGMAROC>5) S MSG1="*** CONTINUE ON NEXT PAGE ***" D BOT^PSGMAR3,HEADER^PSGMAR3 S PSGMAROC=1
- Q
- ORSET ; order record set
- Q:PST["P"!P(9)=""
- S PSGMFOR="",(SD,X)=$P(P(2),".") Q:X>PSGPLF S FD=$P(P(3),"."),PSGOES="",X=P(9) D EN^PSGS0 S T=PSGS0XT
- S X="" I "OB"]PST,$P(P(9),"^")'["@",P(2)'>PSGPLS,P(3)'<PSGPLF,P(11),T<1441,T'="D" S X=P(11),PSGPLC=1
- E I "OB"]PST!(PST["OV") K PSGMAR D SETL0 S (Q,X)="" F QX=0:0 S Q=$O(PSGMAR(Q)) Q:Q="" S X=X_$E("0",2-$L(Q))_Q_"-"
- S TMSTR=X
- K HCD,HM,I,J,PSGD,PLSD,CD,M,MID,MN,ND,ND1,OD,ST,QD1,QD2,QQ,TS,UD,WDT,WS,WS1,X,X1,X2 Q
- Q
- SETL0 ;*** Set variable to use in ^PSGPL0 to calculate admin time.
- K PSGMAR S PSGPLC=0
- S ND1=P(4),ST=P(2),PLSD=P(3),TS=P(11),MN=T,ND=P(9) I $S(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E) S PSGPLC="OI" Q
- D ENIV^PSGPL0
- Q
- ;
- RPHINIT(RPH) ; Find initial for the person who completed the IV order.
- S RPH=$P($G(^PS(55,PSGP,"IV",+ON,4)),U,4)
- S:+RPH RPH=$$DEFINIT(+RPH)
- I RPH="" S RPH="_____"
- Q
- DEFINIT(X) ;
- S X=$G(^VA(200,X,0)),RPH=$P(X,U,2) Q:RPH]"" RPH
- S X=$P(X,U),RPH=$E(X,$F(X,","))_$E(X) Q RPH
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMIV 7069 printed Feb 18, 2025@23:27:56 Page 2
- PSGMIV ;BIR/MV-IV ORDER FOR THE 24 HOUR MAR. ;25 Nov 98 / 9:07 AM
- +1 ;;5.0;INPATIENT MEDICATIONS;**4,20,21,28,58,111,131,145,267,275**;16 DEC 97;Build 157
- +2 ;
- +3 ; Reference to ^PS(55 supported by DBIA #2191.
- +4 ; Reference to ^PS(52.7 supported by DBIA #2173.
- +5 ;
- START ;*** Read IV orders
- +1 SET ON=""
- +2 FOR PSGMARED=PSGPLS-.0001:0
- SET PSGMARED=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGMARED))
- if 'PSGMARED
- QUIT
- FOR
- SET ON=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGMARED,ON))
- if ON=""
- QUIT
- DO IV
- +3 QUIT
- IV ;*** Sort IV orders for 24 Hrs MAR.
- +1 KILL DRG,P
- NEW X,ON55,PSJLABEL
- SET DFN=PSGP
- SET PSJLABEL=1
- DO GT55^PSIVORFB
- +2 if P(2)>PSGPLF
- QUIT
- +3 SET X=$PIECE(P("MR"),U,2)
- if XTYPE=2&(X["IV")
- QUIT
- if XTYPE=3&(PST="S")&'($SELECT(X="IV"
- QUIT
- +4 SET QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
- +5 SET QST=$SELECT(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE
- +6 ;DEM (05/30/2006) - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
- NEW PSGMARWC
- +7 SET PSGMARWC=PSGMARWN
- +8 IF $GET(DRG)
- SET X=$SELECT($GET(DRG("AD",1)):DRG("AD",1),1:$GET(DRG("SOL",1)))
- SET X=$EXTRACT($PIECE(X,U,2),1,20)_U_ON_"V"
- Begin DoDot:1
- +9 NEW A
- +10 SET A=$GET(^PS(55,PSGP,"IV",+ON,"DSS"))
- IF $PIECE(A,"^")]""
- SET PSGMARWN="C!"_$PIECE(A,"^")
- IF $GET(SUB1)]""
- IF $GET(SUB2)]""
- IF '$DATA(^TMP($JOB,TM,PSGMARWN,SUB1,SUB2))
- Begin DoDot:2
- +11 NEW X,X1,Y
- +12 DO SPN^PSGMAR0
- +13 QUIT
- End DoDot:2
- +14 IF PSGSS="P"!(PSGSS="C")!(PSGSS="L")
- SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
- QUIT
- +15 if PSGRBPPN="P"
- SET ^TMP($JOB,TM,PSGMARWN,PPN,PSJPRB,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
- +16 if PSGRBPPN="R"
- SET ^TMP($JOB,TM,PSGMARWN,PSJPRB,PPN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
- End DoDot:1
- +17 if PSGMARWN'=PSGMARWC
- SET PSGMARWN=PSGMARWC
- +18 QUIT
- PRT ;*** Print IV orders.
- +1 KILL TS,P,DRG
- NEW ON55,LN,PSJLABEL
- SET PSJLABEL=1
- +2 SET ON=$PIECE(DAO,U,2)
- SET DFN=$PIECE(PN,U,2)
- if ON["V"
- DO GT55^PSIVORFB
- +3 if ON["P"
- DO GT531^PSIVORFA(DFN,ON)
- +4 SET TS=1
- SET TMSTR=""
- IF P(9)]""
- DO ORSET
- DO TS^PSGMAR3(P(11))
- +5 FOR X="LOG",2,3
- if P(X)
- SET P(X)=$$ENDTC1^PSGMI(P(X))
- +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 SET PSGLFFD=PSGPLF
- +8 DO INITOPI^PSGMMIVC
- +9 NEW NAMENEED,NEED,X
- SET NAMENEED=0
- +10 DO LNNEED
- DO PRTIV
- +11 QUIT
- LNNEED ;*** Find lines needed per label.
- +1 ;*** If OPI<29 char, it is ok to put INITs in the same line.
- +2 ;*** Add number of lines needed for additives and solutions and 1 line
- +3 ;*** for infusion rate and x line for OPI. Divide by 5 to determine
- +4 ;*** of label(s) needed for this order.
- +5 FOR X="AD","SOL"
- DO NAMENEED^PSJMUTL(X,47,.NEED)
- SET NAMENEED=NAMENEED+NEED
- +6 NEW OPILEN,OPILAST
- SET OPILAST=$SELECT(($GET(ON55)["V"):$ORDER(^PS(55,DFN,"IV",ON55,10," "),-1),1:"")
- SET OPILEN=$SELECT(OPILAST:(74*OPILAST),1:$LENGTH(P("OPI")))
- +7 SET X=(OPILEN\47)+((OPILEN#47)>28)+1+($PIECE(P("OPI"),"^")]""&(P(4)="C"))
- +8 SET X=(NAMENEED+X+2)
- SET X=$SELECT(X<6:1,1:((X-6)\5)+2)
- +9 SET LN=$SELECT(TS/6>X:TS/6,1:X)
- +10 QUIT
- +11 ;
- OS ; order record set
- +1 QUIT
- +2 ;
- PRTIV ;*** Print IV order on MAR
- +1 DO ONHOLD^PSGMMAR2
- +2 IF PSGMAROC
- IF (PSGMAROC+LN)>6
- DO BOT^PSGMAR3
- DO HEADER^PSGMAR3
- +3 NEW PSGL
- SET PSGL="|"
- +4 SET PSGMAROC=PSGMAROC+1
- WRITE !?6,"|",?19,"|",?48,PSGL,$GET(TS(1)),?55,"|"
- +5 WRITE !,$EXTRACT(P("LOG"),1,5)," |"
- +6 IF ON["V"
- Begin DoDot:1
- +7 IF $GET(ONHOLD)
- WRITE "O N H O L D"
- QUIT
- +8 WRITE $EXTRACT(P(2),1,5)_$EXTRACT(P(2),9,14)," |",P(3)
- +9 QUIT
- End DoDot:1
- +10 if ON["P"
- WRITE "P E N D I N G"
- +11 WRITE ?39,"(",$EXTRACT(PSGP(0))_$EXTRACT(PSSN,8,12)_")"
- +12 WRITE ?48,PSGL,$GET(TS(2)),?55,"|"
- SET L=3
- +13 NEW NAME,PSIVX
- +14 FOR PSIVX=0:0
- SET PSIVX=$ORDER(DRG("AD",PSIVX))
- if 'PSIVX
- QUIT
- DO NAME^PSIVUTL(DRG("AD",PSIVX),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,PSGL,$GET(TS(L)),?55,"|"
- if (PSIVX=1&((PSGST="O")!(PSGST="C")))
- DO TMSTR^PSGMAR3
- DO L(1)
- +15 if $GET(DRG("SOL",0))
- WRITE !,"in "
- +16 NEW PSJPRT2
- +17 FOR PSIVX=0:0
- SET PSIVX=$ORDER(DRG("SOL",PSIVX))
- if 'PSIVX
- QUIT
- DO NAME^PSIVUTL(DRG("SOL",PSIVX),47,.NAME,1)
- FOR Y=0:0
- SET Y=$ORDER(NAME(Y))
- if 'Y
- QUIT
- Begin DoDot:1
- +18 if (Y>1!(PSIVX>1))
- WRITE !
- WRITE ?4,NAME(Y)
- if L=3
- WRITE ?47,PSGST
- WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
- if L=3
- DO TMSTR^PSGMAR3
- DO L(1)
- +19 SET PSJPRT2=$PIECE(^PS(52.7,+DRG("SOL",PSIVX),0),U,4)
- IF PSJPRT2]""
- WRITE !?7,PSJPRT2
- if L=3
- WRITE ?47,PSGST
- WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
- if L=3
- DO TMSTR^PSGMAR3
- DO L(1)
- End DoDot:1
- +20 WRITE !,$PIECE(P("MR"),U,2)," ",P(9)," ",P(8)
- WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
- IF L>5
- IF (L#5)
- WRITE !
- +21 IF '$ORDER(DRG("AD",0))!('$ORDER(DRG("SOL",0)))
- WRITE !?48,PSGL,$GET(TS(L)),?55,"|"
- SET L=5
- +22 IF P(4)="C"
- IF '(L#5)
- IF P("OPI")=""
- WRITE !,"*CAUTION-CHEMOTHERAPY*"
- SET L=L+1
- QUIT
- +23 IF P(4)="C"
- DO L(1)
- WRITE !,"*CAUTION-CHEMOTHERAPY*",?48,PSGL,$GET(TS(L)),?55,"|"
- +24 IF (L#5)=0
- IF ($LENGTH($PIECE(P("OPI"),"^"))<29)
- IF (TS<7)
- SET L=L+1
- +25 IF '$TEST
- DO L(1)
- +26 if P("OPI")=""&(TS>6)
- WRITE !
- +27 IF P("OPI")'=""
- IF '$$OPI(PSGP,ON55)
- Begin DoDot:1
- +28 if (L#6)=1
- WRITE !
- +29 FOR Y=1:1:$LENGTH($PIECE(P("OPI"),"^")," ")
- SET Y1=$PIECE($PIECE(P("OPI"),"^")," ",Y)
- Begin DoDot:2
- End DoDot:2
- WRITE Y1," "
- +30 IF ($X+$LENGTH(Y1))>47
- WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
- DO L(1)
- WRITE !
- End DoDot:1
- +31 IF L>TS
- IF (L#6)
- WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
- SET L=L+1
- if L#6=0
- WRITE !
- +32 IF (TS-1)>L
- WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
- Begin DoDot:1
- +33 FOR L=L+1:1:TS-1
- DO L(0)
- WRITE !?48,PSGL,$GET(TS(L)),?55,"|"
- +34 SET L=L+1
- End DoDot:1
- +35 FOR
- if '(L#6)
- QUIT
- WRITE !?48,PSGL,$GET(TS(L)),?55,"|"
- SET L=L+1
- +36 IF '(L#6)
- IF (P("OPI")="")
- WRITE !
- +37 IF P("OPI")]""
- IF (L>6)
- WRITE !
- +38 WRITE ?29,"RPH: ",PSGLRPH,?38,"RN: ",PSGLRN,?48,PSGL,$GET(TS(L)),?55,"|"
- if PSGMAROC<6
- WRITE !?7,LN2
- +39 QUIT
- +40 ;
- OPI(DFN,ORDER,OPITEXT,OPIPRINT) ; Retrieve, format, and print Other Print Info
- +1 NEW TXTLN
- SET TXTLN=$$GETSIOPI^PSJBCMA5($GET(DFN),$GET(ORDER),1)
- IF 'TXTLN
- QUIT 0
- +2 NEW TXTLN,TXT,I,TMPMARX,MARXTXT,LAST,II,Y
- KILL MARX
- SET LAST=0
- SET TMPMARX=""
- SET PSGL=$SELECT(($GET(PSGL)]""):PSGL,1:"|")
- +3 IF ORDER["V"
- SET TXTLN=0
- FOR I=1:1
- SET TXTLN=$ORDER(^PS(55,DFN,"IV",+ORDER,10,TXTLN))
- if 'TXTLN
- QUIT
- Begin DoDot:1
- +4 SET MARXTXT=^PS(55,DFN,"IV",+ORDER,10,TXTLN,0)
- DO TXT^PSGMUTL(MARXTXT,47)
- SET LAST=$ORDER(TMPMARX(" "),-1)
- SET II=0
- FOR
- SET II=$ORDER(MARX(II))
- if 'II
- QUIT
- SET TMPMARX(LAST+II)=MARX(II)
- End DoDot:1
- +5 IF ORDER["P"
- SET TXTLN=0
- FOR I=1:1
- SET TXTLN=$ORDER(^PS(53.1,+ORDER,16,TXTLN))
- if 'TXTLN
- QUIT
- Begin DoDot:1
- +6 SET MARXTXT=^PS(53.1,+ORDER,16,TXTLN,0)
- DO TXT^PSGMUTL(MARXTXT,47)
- SET LAST=$ORDER(TMPMARX(" "),-1)
- SET II=0
- FOR
- SET II=$ORDER(MARX(II))
- if 'II
- QUIT
- SET TMPMARX(LAST+II)=MARX(II)
- End DoDot:1
- +7 IF $GET(OPIPRINT)
- KILL MARX
- MERGE MARX=TMPMARX
- SET I=0
- FOR
- SET I=$ORDER(MARX(I))
- if 'I
- QUIT
- Begin DoDot:1
- +8 if (L#6)=0
- WRITE !
- +9 SET Y1=MARX(I)
- WRITE Y1," ",?48,PSGL,$GET(TS(L)),?55,"|"
- DO L(1)
- WRITE !
- End DoDot:1
- +10 IF $GET(OPITEXT)
- MERGE OPITEXT=TMPMARX
- +11 QUIT 1
- L(X) ;***Check to see if a new block is needed.
- +1 SET L=L+X
- +2 IF L#6=0
- IF PSGMAROC<6
- WRITE !,"See next label for continuation",?48,PSGL,$GET(TS(L)),?55,"|"
- if PSGMAROC<6
- WRITE !?7,LN2
- SET PSGMAROC=PSGMAROC+1
- SET L=L+1
- Begin DoDot:1
- +3 IF LN>6
- IF (PSGMAROC>5)
- SET MSG1="*** CONTINUE ON NEXT PAGE ***"
- DO BOT^PSGMAR3
- DO HEADER^PSGMAR3
- SET PSGMAROC=1
- End DoDot:1
- +4 QUIT
- ORSET ; order record set
- +1 if PST["P"!P(9)=""
- QUIT
- +2 SET PSGMFOR=""
- SET (SD,X)=$PIECE(P(2),".")
- if X>PSGPLF
- QUIT
- SET FD=$PIECE(P(3),".")
- SET PSGOES=""
- SET X=P(9)
- DO EN^PSGS0
- SET T=PSGS0XT
- +3 SET X=""
- IF "OB"]PST
- IF $PIECE(P(9),"^")'["@"
- IF P(2)'>PSGPLS
- IF P(3)'<PSGPLF
- IF P(11)
- IF T<1441
- IF T'="D"
- SET X=P(11)
- SET PSGPLC=1
- +4 IF '$TEST
- IF "OB"]PST!(PST["OV")
- KILL PSGMAR
- DO SETL0
- SET (Q,X)=""
- FOR QX=0:0
- SET Q=$ORDER(PSGMAR(Q))
- if Q=""
- QUIT
- SET X=X_$EXTRACT("0",2-$LENGTH(Q))_Q_"-"
- +5 SET TMSTR=X
- +6 KILL HCD,HM,I,J,PSGD,PLSD,CD,M,MID,MN,ND,ND1,OD,ST,QD1,QD2,QQ,TS,UD,WDT,WS,WS1,X,X1,X2
- QUIT
- +7 QUIT
- SETL0 ;*** Set variable to use in ^PSGPL0 to calculate admin time.
- +1 KILL PSGMAR
- SET PSGPLC=0
- +2 SET ND1=P(4)
- SET ST=P(2)
- SET PLSD=P(3)
- SET TS=P(11)
- SET MN=T
- SET ND=P(9)
- IF $SELECT(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E)
- SET PSGPLC="OI"
- QUIT
- +3 DO ENIV^PSGPL0
- +4 QUIT
- +5 ;
- RPHINIT(RPH) ; Find initial for the person who completed the IV order.
- +1 SET RPH=$PIECE($GET(^PS(55,PSGP,"IV",+ON,4)),U,4)
- +2 if +RPH
- SET RPH=$$DEFINIT(+RPH)
- +3 IF RPH=""
- SET RPH="_____"
- +4 QUIT
- DEFINIT(X) ;
- +1 SET X=$GET(^VA(200,X,0))
- SET RPH=$PIECE(X,U,2)
- if RPH]""
- QUIT RPH
- +2 SET X=$PIECE(X,U)
- SET RPH=$EXTRACT(X,$FIND(X,","))_$EXTRACT(X)
- QUIT RPH
