- PSBOCP ;BIRMINGHAM/TEJ-COVERSHEET PRN OVERVIEW REPORT ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**32,50**;Mar 2004;Build 78
- ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
- ;
- ; Reference/IA
- ; File 4/10090
- EN ; Entry Point
- N PSBX1X,RESULTS,RESULT,PSBFUTR
- S PSBFUTR=$TR(PSBRPT(1),"~","^")
- S (PSBOCRIT,PSBXFLG,PSBCFLG)="" ; Order Status search criteria - "A"ctive, "D"C ed, "E"xpired"
- S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_"D" S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_"E" S:$P(PSBFUTR,U,5) PSBOCRIT=PSBOCRIT_"A"
- S:$P(PSBFUTR,U,4) PSBOCRIT=PSBOCRIT_"F"
- S:$P(PSBFUTR,U,11) PSBXFLG=1
- I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
- K PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD
- S PSBSORT=1
- D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=Y
- D GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
- S PSBB4=0 S:RESULTS(0)>0 PSBB4=+RESULTS(0)
- D GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
- S PSBAFT=0 S:RESULTS(0)>0 PSBAFT=+RESULTS(0)
- K ^XTMP("PSBO",$J,"PSBLIST")
- S (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
- K PSBLIST,PSBLIST2
- S PSBXDFN=$P(PSBRPT(.1),U,2)
- S PSBLIST(PSBXDFN)=""
- S (PSBX1X,PSBTOT)=0
- F S PSBX1X=$O(PSBLIST(PSBX1X)) Q:+PSBX1X=0 D
- .D RPC^PSBCSUTL(.PSBAREA,PSBX1X)
- .M PSBDATA=@PSBAREA
- .S PSBX2X=1
- .S (PSBLIST2("ACTIVE"),PSBLIST2("FUTURE"),PSBLIST2("EXPIRED/DC'd"),PSBLIST2(" * ERROR * "))=0
- .F S PSBX2X=$O(PSBDATA(PSBX2X)) Q:+PSBX2X=0 D
- ..S PSBDATA=PSBDATA(PSBX2X)
- ..I ($P(PSBDATA,U)="ORD") I $P(PSBDATA,U,6)'="P" F S PSBX2X=$O(PSBDATA(PSBX2X)) S PSBDATA=PSBDATA(PSBX2X) Q:$P(PSBDATA,U)="END"
- ..I ($P(PSBDATA,U)="ORD") K PSBORDN D Q
- ...K PSBDRUGN
- ...S PSBSCHTY="P"
- ...S PSBORDN=$P(PSBDATA,U,3)
- ...S PSBTB=$P(PSBDATA,U,29) S PSBTB=$S(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
- ...S PSBTB(PSBORDN,PSBTB)=""
- ...S PSBSTS1=$P(PSBDATA,U,23)
- ...S PSBSTS=$S((PSBSTS1="A")&(($P(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS1="H":"Hold",PSBSTS1="D":"Discontinued",PSBSTS1="DE":"Discontinued (Edit)",(PSBSTS1="E")!($P(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ERROR * ")
- ...S PSBSTS(PSBORDN,PSBSTS)=""
- ...S V=$$FMADD^XLFDT(PSBNOWX,,,PSBB4)
- ...S PSBSTSX=$S($P(PSBDATA,U,27)'>PSBNOWX:"EXPIRED/DC'd",$P(PSBDATA,U,22)'>V:"ACTIVE",V:"FUTURE",1:" * ERROR * ")
- ...S PSBLIST2(PSBSTSX,$P(PSBDATA,U,9),PSBORDN)="" S PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
- ...S:PSBOCRIT[$E(PSBSTSX,1) PSBTOT=PSBTOT+1
- ...S PSBSCHTY(PSBORDN,PSBSCHTY)=""
- ...S PSBDOSR=$P(PSBDATA,U,10)_", "_$P(PSBDATA,U,11)
- ...S PSBDOSR=$TR($E(PSBDOSR,1)," ")_$E(PSBDOSR,2,999)
- ...S PSBDOSR(PSBORDN,PSBDOSR)=""
- ...S PSBLSTG=$P(PSBDATA,U,28)
- ...I PSBLSTG]"" S PSBLSTG(PSBORDN,$$FMTDT^PSBOCE1($E(PSBLSTG,1,12)))=""
- ...S PSBLSTX=$S(PSBLSTG]"":$$LSTX(PSBLSTG,PSBNOWX),1:" ")
- ...S PSBLSTX(PSBORDN,PSBLSTX)=""
- ...; ** SPECIAL INSTRUCTIONS **
- ...S PSBX2X=PSBX2X+1
- ...S PSBSI=$P(PSBDATA(PSBX2X),U,2)
- ...I PSBSI]" " S PSBSI(PSBORDN,PSBSI)=""
- ...S PSBOSTDT=$P(PSBDATA,U,22)
- ...S PSBOSTDT(PSBORDN,PSBOSTDT)=""
- ...S PSBOSPDT=$P(PSBDATA,U,27)
- ...S PSBOSPDT(PSBORDN,PSBOSPDT)=""
- ..Q:'$D(PSBORDN)
- ..I "^DD^ADD^SOL"[(U_$P(PSBDATA(PSBX2X),U)) D Q
- ...F I=PSBX2X:1 S PSBDATA1=PSBDATA(I) D Q:$D(PSBOMDR(PSBORDN))
- ....I "^DD^ADD^SOL"[(U_$P(PSBDATA1,U)) S PSBX2X=I S PSBDRUGN=$G(PSBDRUGN,"")_$P(PSBDATA1,U,3)_", " Q
- ....S $E(PSBDRUGN,$L(PSBDRUGN)-1)="" S PSBDRUGN(PSBORDN,$E(PSBDRUGN,1,250))=PSBDRUGN
- ....S PSBOMDR(PSBORDN,$E((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
- ..I $P(PSBDATA,U)="END" Q
- ..Q:'$D(PSBORDN)
- ..I $P(PSBDATA(PSBX2X),U)="ORF" D Q
- ...S PSBDATA=PSBDATA(PSBX2X)
- ...S:$P(PSBDATA,U,2)]"" PSBFLGD(PSBORDN,$P(PSBDATA,U,3)_" - "_$P(PSBDATA,U,4))=""
- ..Q:'$D(PSBORDN)
- ..I ($P(PSBDATA,U)="ADM")&($P(PSBDATA,U,4)]"") D Q
- ...S PSBXID=$P(PSBDATA,U,6)_U_$P(PSBDATA,U,4),PSBADM(PSBORDN,(-1*($P(PSBDATA,U,6))),PSBXID)=PSBDATA
- ...I $O(PSBSCHTY(PSBORDN,""))="P" S PSBPRNR(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,9)
- ...I $P(PSBDATA,U,3)]"" S PSBBID(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,3)
- ...S:PSBXFLG PSBLGD(PSBORDN,"X","INITIALS",$P(PSBDATA,U,8))=""
- ...I $P(PSBDATA(PSBX2X+1),U)="CMT" S PSBX2X=PSBX2X+1 F PSBX3X=PSBX2X:1 S PSBDATA=PSBDATA(PSBX3X) Q:($P(PSBDATA,U)'="CMT") D
- ....S PSBX2X=PSBX3X
- ....I $P(PSBDATA,U,3)]"" S PSBPRNEF(PSBORDN,$P(PSBXID,U,2))=$P(PSBDATA,U,3)
- ....I PSBCFLG I $P(PSBDATA,U,2)'="" S PSBLGD(PSBORDN,"C","INITIALS",$P(PSBDATA,U,4))="",PSBCMT(PSBORDN,$P(PSBXID,U,2),(-1*$P(PSBDATA,U,6)),PSBX2X)=PSBDATA
- I +PSBTOT=0 K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
- D CREATHDR^PSBOCP1
- D SUBHDR^PSBOCE
- D BLDRPT
- D WRTRPT^PSBOCP1
- Q
- BLDRPT ; Buld REPORT DATA
- K PSBL2ULN
- S PSBTOPHD=PSBLNTOT-2
- I '$D(PSBLIST2) D Q
- .S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
- S PSBMORE=5 F PSBX1X="ACTIVE","FUTURE","EXPIRED/DC'd"," * ERROR * " D
- .I PSBX1X'=" * ERROR * " S PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_$S(PSBLIST2(PSBX1X)=1:" Order",1:" Orders")_"]" S PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
- .Q:PSBLIST2(PSBX1X)=0
- .Q:PSBOCRIT'[$E(PSBX1X,1)
- .S:$L(PSBSUM)>$G(PSBL2ULN,0) PSBL2ULN=$L(PSBSUM)
- .S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBL2ULN),"" "",""=""),!"
- .S PSBOUTP($$PGTOT,PSBLNTOT)="W !"
- .K PSBDATA
- .S X0="",PSBTOT1=0
- .F S X0=$O(PSBLIST2(PSBX1X,X0)) Q:X0="" S PSBX2X="" F S PSBX2X=$O(PSBLIST2(PSBX1X,X0,PSBX2X)) Q:PSBX2X="" D
- ..M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"X","INITIALS") M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"C","INITIALS")
- ..S PSBDATA(1,1)=$O(PSBTB(PSBX2X,""))
- ..S PSBDATA(1,2)=$O(PSBSTS(PSBX2X,""))
- ..S PSBDATA(1,3)=$O(PSBSCHTY(PSBX2X,""))
- ..S Y0=$O(PSBOMDR(PSBX2X,"")) I Y0]"" S PSBDATA(1,4)="("_X0_")",PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
- ..S PSBDATA(1,5)=$O(PSBLSTG(PSBX2X,""))
- ..S PSBDATA(1,6)=$O(PSBLSTX(PSBX2X,""))
- ..S PSBDATA(1,7)=$$FMTDT^PSBOCE1($O(PSBOSTDT(PSBX2X,"")))
- ..S PSBDATA(1,8)=$$FMTDT^PSBOCE1($E($O(PSBOSPDT(PSBX2X,"")),1,12))
- ..S PSBSIDAT(1)=$O(PSBSI(PSBX2X,""))
- ..S PSBTOT1=PSBTOT1+1
- ..K PSBDATA(2),PSBDATA(3),PSBSILN
- ..D BUILDLN,SIOPI^PSBOCM(.PSBSIDAT,PSBTAB8,$S(PSBX2X["V":"Other Print Info:",1:""))
- ..I $D(PSBRPLN) S PSBMORE=$O(PSBRPLN(""),-1)+6 I $D(PSBSILN) S PSBMORE=PSBMORE+$O(PSBSILN(""),-1)
- ..K PSB1 I $D(PSBFLGD(PSBX2X)) S PSB="" F S PSB=$O(PSBFLGD(PSBX2X,PSB)) Q:PSB="" I ($P(PSB,":")'="NOX")&($P(PSB,":")'="STAT") S PSB1=$G(PSB1,"")_PSB
- ..S PSBCNT=PSBTOT1_" "_$G(PSB1,"")
- ..S PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
- ..S I="" F S I=$O(PSBRPLN(I)) Q:+I=0 D
- ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
- ..S I="" F S I=$O(PSBSILN(I)) Q:+I=0 D
- ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
- ..S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
- ..K PSBRPLN,PSBDATA
- D:+PSBTOT>0 LGD^PSBOCM
- Q
- BUILDLN ; Constr recs
- K J S J(0)="" F PSBFLD=1:1:8 S J=1 D FORMDAT(PSBFLD) S J($O(PSBRPLN(""),-1))=""
- ; Write administration info...
- Q:'PSBXFLG
- S J=($O(J(""),-1)+1),PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
- S (N,Y)=""
- F S Y=$O(PSBADM(PSBX2X,Y)) Q:Y']"" D
- .F S N=$O(PSBADM(PSBX2X,Y,N)) Q:N']"" D
- ..N PSBEIECMT S PSBEIECMT="" I $D(PSBPRNEF(PSBX2X,$P(N,U,2))),$P($G(PSBRPT(.2)),U,8)=0 S PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,$P(N,U,2))
- ..I $D(PSBBID(PSBX2X,$P(N,U,2))) S PSBDATA(2,0)="BAG ID: "_PSBBID(PSBX2X,$P(N,U,2))
- ..S $E(PSBDATA(2,0),25)="ACTION BY: "_$P(PSBADM(PSBX2X,Y,N),U,7)_" "_$$FMTDT^PSBOCE1($E($P(PSBADM(PSBX2X,Y,N),U,6),1,12))
- ..S X=$P(PSBADM(PSBX2X,Y,N),U,5) S $E(PSBDATA(2,0),56)="ACTION: "_$S(X="G":"GIVEN",X="R":"REFUSED",X="RM":"REMOVED",X="H":"HELD",X="S":"STOPPED",X="I":"INFUSING",X="C":"COMPLETED",X="M":"MISSING DOSE",X=" ":"*UNKNOWN*",1:" ")
- ..I $D(PSBPRNR(PSBX2X)) S $E(PSBDATA(2,0),72)="PRN REASON: "_PSBPRNR(PSBX2X,$P(N,U,2))
- ..I $G(PSBDATA(2,0))]" " D WRAPPER(1,132-1,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
- ..I $D(PSBPRNEF(PSBX2X,$P(N,U,2))) S PSBDATA(2,0)="PRN EFFECTIVENESS: "_PSBPRNEF(PSBX2X,$P(N,U,2))_PSBEIECMT
- ..I $G(PSBDATA(2,0))]" " D WRAPPER(30,132-30,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
- ..I ('PSBCFLG)!('$D(PSBCMT(PSBX2X,$P(N,U,2)))) S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1 Q
- ..S X="" F S X=$O(PSBCMT(PSBX2X,$P(N,U,2),X)) Q:X']"" D
- ...N PSBDAT S PSBDAT="" F S PSBDAT=$O(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT)) Q:PSBDAT']"" D
- ....S PSBDATA(2,0)="COMMENT BY: "_$S($P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,5)]"":$P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,5)_" "_$$FMTDT^PSBOCE1($E($P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,6),1,12)),1:" n/a ")
- ....S PSBDATA(2,0)=PSBDATA(2,0)_" COMMENT: "_$S($P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,2)]"":$P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,2),1:" ")
- ....I $G(PSBDATA(2,0))]" " D WRAPPER(30,132-30,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
- ..S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
- Q
- FORMDAT(FLD) ;
- K PSBVAL
- Q:'$D(PSBDATA(1,FLD))
- S PSBVAL=PSBDATA(1,FLD)
- D WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
- I FLD=4 S J=$O(J(""),-1)+1,PSBVAL=PSBDATA(1,4,0) D WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
- Q
- PGTOT(X) ;mnt PAGE Number
- I (PSBLNTOT+PSBMORE)>(IOSL) D PGC^PSBOCE1
- I $G(X,1) S PSBLNTOT=PSBLNTOT+$G(X,1),PSBMORE=PSBMORE-$G(X,1)
- Q PSBPGNUM
- WRAPPER(X,Y,Z) ; Text WRAP
- N PSB
- I ($L(Z)>0),$F(Z,"""")>1 F Q:$F(Z,"""")'>1 S Z=$TR(Z,"""","^")
- F Q:'$L(Z) D
- .I $L(Z)<Y S $E(PSBRPLN(J),X)=Z S Z="" Q
- .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
- .S:PSB<1 PSB=Y
- .S $E(PSBRPLN(J),X)=$E(Z,1,PSB)
- .I $L(PSBRPLN(J),"^")>1 F X=1:1:$L(PSBRPLN(J),"^")-1 S $P(PSBRPLN(J),"^",X)=$P(PSBRPLN(J),"^",X)_""""
- .S PSBRPLN(J)=$TR(PSBRPLN(J),"^","""")
- .S Z=$E(Z,PSB+1,250),J=J+1,J(J)=""
- Q ""
- LSTX(P,O) ;
- S DT=$$FMDIFF^XLFDT(O,P,2)
- I ((DT\60)<1) Q "0d 0h 1m"
- S D=(DT\(60*60*24)) S DT=DT-(D*(60*60*24))
- S H=(DT\(60*60)) S DT=DT-(H*(60*60))
- S M=((DT+30)\(60)) S DT=DT-(M*(60))
- Q D_"d "_H_"h "_M_"m"
- PSBOCP ;BIRMINGHAM/TEJ-COVERSHEET PRN OVERVIEW REPORT ;Mar 2004
- +1 ;;3.0;BAR CODE MED ADMIN;**32,50**;Mar 2004;Build 78
- +2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
- +3 ;
- +4 ; Reference/IA
- +5 ; File 4/10090
- EN ; Entry Point
- +1 NEW PSBX1X,RESULTS,RESULT,PSBFUTR
- +2 SET PSBFUTR=$TRANSLATE(PSBRPT(1),"~","^")
- +3 ; Order Status search criteria - "A"ctive, "D"C ed, "E"xpired"
- SET (PSBOCRIT,PSBXFLG,PSBCFLG)=""
- +4 IF $PIECE(PSBFUTR,U,7)
- SET PSBOCRIT=PSBOCRIT_"D"
- IF $PIECE(PSBFUTR,U,8)
- SET PSBOCRIT=PSBOCRIT_"E"
- IF $PIECE(PSBFUTR,U,5)
- SET PSBOCRIT=PSBOCRIT_"A"
- +5 IF $PIECE(PSBFUTR,U,4)
- SET PSBOCRIT=PSBOCRIT_"F"
- +6 IF $PIECE(PSBFUTR,U,11)
- SET PSBXFLG=1
- +7 IF $DATA(PSBRPT(.2))
- IF $PIECE(PSBRPT(.2),U,8)
- SET PSBCFLG=1
- +8 KILL PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD
- +9 SET PSBSORT=1
- +10 DO NOW^%DTC
- SET (Y,PSBNOWX)=%
- DO DD^%DT
- SET PSBDTTM=Y
- +11 DO GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
- +12 SET PSBB4=0
- IF RESULTS(0)>0
- SET PSBB4=+RESULTS(0)
- +13 DO GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
- +14 SET PSBAFT=0
- IF RESULTS(0)>0
- SET PSBAFT=+RESULTS(0)
- +15 KILL ^XTMP("PSBO",$JOB,"PSBLIST")
- +16 SET (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
- +17 KILL PSBLIST,PSBLIST2
- +18 SET PSBXDFN=$PIECE(PSBRPT(.1),U,2)
- +19 SET PSBLIST(PSBXDFN)=""
- +20 SET (PSBX1X,PSBTOT)=0
- +21 FOR
- SET PSBX1X=$ORDER(PSBLIST(PSBX1X))
- IF +PSBX1X=0
- QUIT
- Begin DoDot:1
- +22 DO RPC^PSBCSUTL(.PSBAREA,PSBX1X)
- +23 MERGE PSBDATA=@PSBAREA
- +24 SET PSBX2X=1
- +25 SET (PSBLIST2("ACTIVE"),PSBLIST2("FUTURE"),PSBLIST2("EXPIRED/DC'd"),PSBLIST2(" * ERROR * "))=0
- +26 FOR
- SET PSBX2X=$ORDER(PSBDATA(PSBX2X))
- IF +PSBX2X=0
- QUIT
- Begin DoDot:2
- +27 SET PSBDATA=PSBDATA(PSBX2X)
- +28 IF ($PIECE(PSBDATA,U)="ORD")
- IF $PIECE(PSBDATA,U,6)'="P"
- FOR
- SET PSBX2X=$ORDER(PSBDATA(PSBX2X))
- SET PSBDATA=PSBDATA(PSBX2X)
- IF $PIECE(PSBDATA,U)="END"
- QUIT
- +29 IF ($PIECE(PSBDATA,U)="ORD")
- KILL PSBORDN
- Begin DoDot:3
- +30 KILL PSBDRUGN
- +31 SET PSBSCHTY="P"
- +32 SET PSBORDN=$PIECE(PSBDATA,U,3)
- +33 SET PSBTB=$PIECE(PSBDATA,U,29)
- SET PSBTB=$SELECT(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
- +34 SET PSBTB(PSBORDN,PSBTB)=""
- +35 SET PSBSTS1=$PIECE(PSBDATA,U,23)
- +36 SET PSBSTS=$SELECT((PSBSTS1="A")&(($PIECE(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS1="H":"Hold",PSBSTS1="D":"Discontinued",PSBSTS1="DE":"Discontinued (Edit)",(PSBSTS1="E")!($PIECE(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ER
- ROR * ")
- +37 SET PSBSTS(PSBORDN,PSBSTS)=""
- +38 SET V=$$FMADD^XLFDT(PSBNOWX,,,PSBB4)
- +39 SET PSBSTSX=$SELECT($PIECE(PSBDATA,U,27)'>PSBNOWX:"EXPIRED/DC'd",$PIECE(PSBDATA,U,22)'>V:"ACTIVE",V:"FUTURE",1:" * ERROR * ")
- +40 SET PSBLIST2(PSBSTSX,$PIECE(PSBDATA,U,9),PSBORDN)=""
- SET PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
- +41 IF PSBOCRIT[$EXTRACT(PSBSTSX,1)
- SET PSBTOT=PSBTOT+1
- +42 SET PSBSCHTY(PSBORDN,PSBSCHTY)=""
- +43 SET PSBDOSR=$PIECE(PSBDATA,U,10)_", "_$PIECE(PSBDATA,U,11)
- +44 SET PSBDOSR=$TRANSLATE($EXTRACT(PSBDOSR,1)," ")_$EXTRACT(PSBDOSR,2,999)
- +45 SET PSBDOSR(PSBORDN,PSBDOSR)=""
- +46 SET PSBLSTG=$PIECE(PSBDATA,U,28)
- +47 IF PSBLSTG]""
- SET PSBLSTG(PSBORDN,$$FMTDT^PSBOCE1($EXTRACT(PSBLSTG,1,12)))=""
- +48 SET PSBLSTX=$SELECT(PSBLSTG]"":$$LSTX(PSBLSTG,PSBNOWX),1:" ")
- +49 SET PSBLSTX(PSBORDN,PSBLSTX)=""
- +50 ; ** SPECIAL INSTRUCTIONS **
- +51 SET PSBX2X=PSBX2X+1
- +52 SET PSBSI=$PIECE(PSBDATA(PSBX2X),U,2)
- +53 IF PSBSI]" "
- SET PSBSI(PSBORDN,PSBSI)=""
- +54 SET PSBOSTDT=$PIECE(PSBDATA,U,22)
- +55 SET PSBOSTDT(PSBORDN,PSBOSTDT)=""
- +56 SET PSBOSPDT=$PIECE(PSBDATA,U,27)
- +57 SET PSBOSPDT(PSBORDN,PSBOSPDT)=""
- End DoDot:3
- QUIT
- +58 IF '$DATA(PSBORDN)
- QUIT
- +59 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA(PSBX2X),U))
- Begin DoDot:3
- +60 FOR I=PSBX2X:1
- SET PSBDATA1=PSBDATA(I)
- Begin DoDot:4
- +61 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA1,U))
- SET PSBX2X=I
- SET PSBDRUGN=$GET(PSBDRUGN,"")_$PIECE(PSBDATA1,U,3)_", "
- QUIT
- +62 SET $EXTRACT(PSBDRUGN,$LENGTH(PSBDRUGN)-1)=""
- SET PSBDRUGN(PSBORDN,$EXTRACT(PSBDRUGN,1,250))=PSBDRUGN
- +63 SET PSBOMDR(PSBORDN,$EXTRACT((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
- End DoDot:4
- IF $DATA(PSBOMDR(PSBORDN))
- QUIT
- End DoDot:3
- QUIT
- +64 IF $PIECE(PSBDATA,U)="END"
- QUIT
- +65 IF '$DATA(PSBORDN)
- QUIT
- +66 IF $PIECE(PSBDATA(PSBX2X),U)="ORF"
- Begin DoDot:3
- +67 SET PSBDATA=PSBDATA(PSBX2X)
- +68 IF $PIECE(PSBDATA,U,2)]""
- SET PSBFLGD(PSBORDN,$PIECE(PSBDATA,U,3)_" - "_$PIECE(PSBDATA,U,4))=""
- End DoDot:3
- QUIT
- +69 IF '$DATA(PSBORDN)
- QUIT
- +70 IF ($PIECE(PSBDATA,U)="ADM")&($PIECE(PSBDATA,U,4)]"")
- Begin DoDot:3
- +71 SET PSBXID=$PIECE(PSBDATA,U,6)_U_$PIECE(PSBDATA,U,4)
- SET PSBADM(PSBORDN,(-1*($PIECE(PSBDATA,U,6))),PSBXID)=PSBDATA
- +72 IF $ORDER(PSBSCHTY(PSBORDN,""))="P"
- SET PSBPRNR(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,9)
- +73 IF $PIECE(PSBDATA,U,3)]""
- SET PSBBID(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,3)
- +74 IF PSBXFLG
- SET PSBLGD(PSBORDN,"X","INITIALS",$PIECE(PSBDATA,U,8))=""
- +75 IF $PIECE(PSBDATA(PSBX2X+1),U)="CMT"
- SET PSBX2X=PSBX2X+1
- FOR PSBX3X=PSBX2X:1
- SET PSBDATA=PSBDATA(PSBX3X)
- IF ($PIECE(PSBDATA,U)'="CMT")
- QUIT
- Begin DoDot:4
- +76 SET PSBX2X=PSBX3X
- +77 IF $PIECE(PSBDATA,U,3)]""
- SET PSBPRNEF(PSBORDN,$PIECE(PSBXID,U,2))=$PIECE(PSBDATA,U,3)
- +78 IF PSBCFLG
- IF $PIECE(PSBDATA,U,2)'=""
- SET PSBLGD(PSBORDN,"C","INITIALS",$PIECE(PSBDATA,U,4))=""
- SET PSBCMT(PSBORDN,$PIECE(PSBXID,U,2),(-1*$PIECE(PSBDATA,U,6)),PSBX2X)=PSBDATA
- End DoDot:4
- End DoDot:3
- QUIT
- End DoDot:2
- End DoDot:1
- +79 IF +PSBTOT=0
- KILL PSBLIST,^XTMP("PSBO",$JOB,"PSBLIST")
- +80 DO CREATHDR^PSBOCP1
- +81 DO SUBHDR^PSBOCE
- +82 DO BLDRPT
- +83 DO WRTRPT^PSBOCP1
- +84 QUIT
- BLDRPT ; Buld REPORT DATA
- +1 KILL PSBL2ULN
- +2 SET PSBTOPHD=PSBLNTOT-2
- +3 IF '$DATA(PSBLIST2)
- Begin DoDot:1
- +4 SET PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
- End DoDot:1
- QUIT
- +5 SET PSBMORE=5
- FOR PSBX1X="ACTIVE","FUTURE","EXPIRED/DC'd"," * ERROR * "
- Begin DoDot:1
- +6 IF PSBX1X'=" * ERROR * "
- SET PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_$SELECT(PSBLIST2(PSBX1X)=1:" Order",1:" Orders")_"]"
- SET PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
- +7 IF PSBLIST2(PSBX1X)=0
- QUIT
- +8 IF PSBOCRIT'[$EXTRACT(PSBX1X,1)
- QUIT
- +9 IF $LENGTH(PSBSUM)>$GET(PSBL2ULN,0)
- SET PSBL2ULN=$LENGTH(PSBSUM)
- +10 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBL2ULN),"" "",""=""),!"
- +11 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !"
- +12 KILL PSBDATA
- +13 SET X0=""
- SET PSBTOT1=0
- +14 FOR
- SET X0=$ORDER(PSBLIST2(PSBX1X,X0))
- IF X0=""
- QUIT
- SET PSBX2X=""
- FOR
- SET PSBX2X=$ORDER(PSBLIST2(PSBX1X,X0,PSBX2X))
- IF PSBX2X=""
- QUIT
- Begin DoDot:2
- +15 MERGE PSBLGD("INITIALS")=PSBLGD(PSBX2X,"X","INITIALS")
- MERGE PSBLGD("INITIALS")=PSBLGD(PSBX2X,"C","INITIALS")
- +16 SET PSBDATA(1,1)=$ORDER(PSBTB(PSBX2X,""))
- +17 SET PSBDATA(1,2)=$ORDER(PSBSTS(PSBX2X,""))
- +18 SET PSBDATA(1,3)=$ORDER(PSBSCHTY(PSBX2X,""))
- +19 SET Y0=$ORDER(PSBOMDR(PSBX2X,""))
- IF Y0]""
- SET PSBDATA(1,4)="("_X0_")"
- SET PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
- +20 SET PSBDATA(1,5)=$ORDER(PSBLSTG(PSBX2X,""))
- +21 SET PSBDATA(1,6)=$ORDER(PSBLSTX(PSBX2X,""))
- +22 SET PSBDATA(1,7)=$$FMTDT^PSBOCE1($ORDER(PSBOSTDT(PSBX2X,"")))
- +23 SET PSBDATA(1,8)=$$FMTDT^PSBOCE1($EXTRACT($ORDER(PSBOSPDT(PSBX2X,"")),1,12))
- +24 SET PSBSIDAT(1)=$ORDER(PSBSI(PSBX2X,""))
- +25 SET PSBTOT1=PSBTOT1+1
- +26 KILL PSBDATA(2),PSBDATA(3),PSBSILN
- +27 DO BUILDLN
- DO SIOPI^PSBOCM(.PSBSIDAT,PSBTAB8,$SELECT(PSBX2X["V":"Other Print Info:",1:""))
- +28 IF $DATA(PSBRPLN)
- SET PSBMORE=$ORDER(PSBRPLN(""),-1)+6
- IF $DATA(PSBSILN)
- SET PSBMORE=PSBMORE+$ORDER(PSBSILN(""),-1)
- +29 KILL PSB1
- IF $DATA(PSBFLGD(PSBX2X))
- SET PSB=""
- FOR
- SET PSB=$ORDER(PSBFLGD(PSBX2X,PSB))
- IF PSB=""
- QUIT
- IF ($PIECE(PSB,":")'="NOX")&($PIECE(PSB,":")'="STAT")
- SET PSB1=$GET(PSB1,"")_PSB
- +30 SET PSBCNT=PSBTOT1_" "_$GET(PSB1,"")
- +31 SET PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
- +32 SET I=""
- FOR
- SET I=$ORDER(PSBRPLN(I))
- IF +I=0
- QUIT
- Begin DoDot:3
- +33 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
- End DoDot:3
- +34 SET I=""
- FOR
- SET I=$ORDER(PSBSILN(I))
- IF +I=0
- QUIT
- Begin DoDot:3
- +35 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
- End DoDot:3
- +36 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
- +37 KILL PSBRPLN,PSBDATA
- End DoDot:2
- End DoDot:1
- +38 IF +PSBTOT>0
- DO LGD^PSBOCM
- +39 QUIT
- BUILDLN ; Constr recs
- +1 KILL J
- SET J(0)=""
- FOR PSBFLD=1:1:8
- SET J=1
- DO FORMDAT(PSBFLD)
- SET J($ORDER(PSBRPLN(""),-1))=""
- +2 ; Write administration info...
- +3 IF 'PSBXFLG
- QUIT
- +4 SET J=($ORDER(J(""),-1)+1)
- SET PSBRPLN(J)=PSBBLANK
- SET J(J)=""
- SET J=J+1
- +5 SET (N,Y)=""
- +6 FOR
- SET Y=$ORDER(PSBADM(PSBX2X,Y))
- IF Y']""
- QUIT
- Begin DoDot:1
- +7 FOR
- SET N=$ORDER(PSBADM(PSBX2X,Y,N))
- IF N']""
- QUIT
- Begin DoDot:2
- +8 NEW PSBEIECMT
- SET PSBEIECMT=""
- IF $DATA(PSBPRNEF(PSBX2X,$PIECE(N,U,2)))
- IF $PIECE($GET(PSBRPT(.2)),U,8)=0
- SET PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,$PIECE(N,U,2))
- +9 IF $DATA(PSBBID(PSBX2X,$PIECE(N,U,2)))
- SET PSBDATA(2,0)="BAG ID: "_PSBBID(PSBX2X,$PIECE(N,U,2))
- +10 SET $EXTRACT(PSBDATA(2,0),25)="ACTION BY: "_$PIECE(PSBADM(PSBX2X,Y,N),U,7)_" "_$$FMTDT^PSBOCE1($EXTRACT($PIECE(PSBADM(PSBX2X,Y,N),U,6),1,12))
- +11 SET X=$PIECE(PSBADM(PSBX2X,Y,N),U,5)
- SET $EXTRACT(PSBDATA(2,0),56)="ACTION: "_$SELECT(X="G":"GIVEN",X="R":"REFUSED",X="RM":"REMOVED",X="H":"HELD",X="S":"STOPPED",X="I":"INFUSING",X="C":"COMPLETED",X="M":"MISSING DOSE",X=" ":"*UNKNOWN*",1:" ")
- +12 IF $DATA(PSBPRNR(PSBX2X))
- SET $EXTRACT(PSBDATA(2,0),72)="PRN REASON: "_PSBPRNR(PSBX2X,$PIECE(N,U,2))
- +13 IF $GET(PSBDATA(2,0))]" "
- DO WRAPPER(1,132-1,PSBDATA(2,0))
- KILL PSBDATA(2)
- SET J=J+1
- +14 IF $DATA(PSBPRNEF(PSBX2X,$PIECE(N,U,2)))
- SET PSBDATA(2,0)="PRN EFFECTIVENESS: "_PSBPRNEF(PSBX2X,$PIECE(N,U,2))_PSBEIECMT
- +15 IF $GET(PSBDATA(2,0))]" "
- DO WRAPPER(30,132-30,PSBDATA(2,0))
- KILL PSBDATA(2)
- SET J=J+1
- +16 IF ('PSBCFLG)!('$DATA(PSBCMT(PSBX2X,$PIECE(N,U,2))))
- SET PSBRPLN(J)=PSBBLANK
- SET J(J)=""
- SET J=J+1
- QUIT
- +17 SET X=""
- FOR
- SET X=$ORDER(PSBCMT(PSBX2X,$PIECE(N,U,2),X))
- IF X']""
- QUIT
- Begin DoDot:3
- +18 NEW PSBDAT
- SET PSBDAT=""
- FOR
- SET PSBDAT=$ORDER(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT))
- IF PSBDAT']""
- QUIT
- Begin DoDot:4
- +19 SET PSBDATA(2,0)="COMMENT BY: "_$SELECT($PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,5)]"":$PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,5)_" "_$$FMTDT^PSBOCE1($EXTRACT($PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSB
- DAT),U,6),1,12)),1:" n/a ")
- +20 SET PSBDATA(2,0)=PSBDATA(2,0)_" COMMENT: "_$SELECT($PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,2)]"":$PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,2),1:" ")
- +21 IF $GET(PSBDATA(2,0))]" "
- DO WRAPPER(30,132-30,PSBDATA(2,0))
- KILL PSBDATA(2)
- SET J=J+1
- End DoDot:4
- End DoDot:3
- +22 SET PSBRPLN(J)=PSBBLANK
- SET J(J)=""
- SET J=J+1
- End DoDot:2
- End DoDot:1
- +23 QUIT
- FORMDAT(FLD) ;
- +1 KILL PSBVAL
- +2 IF '$DATA(PSBDATA(1,FLD))
- QUIT
- +3 SET PSBVAL=PSBDATA(1,FLD)
- +4 DO WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
- +5 IF FLD=4
- SET J=$ORDER(J(""),-1)+1
- SET PSBVAL=PSBDATA(1,4,0)
- DO WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
- +6 QUIT
- PGTOT(X) ;mnt PAGE Number
- +1 IF (PSBLNTOT+PSBMORE)>(IOSL)
- DO PGC^PSBOCE1
- +2 IF $GET(X,1)
- SET PSBLNTOT=PSBLNTOT+$GET(X,1)
- SET PSBMORE=PSBMORE-$GET(X,1)
- +3 QUIT PSBPGNUM
- WRAPPER(X,Y,Z) ; Text WRAP
- +1 NEW PSB
- +2 IF ($LENGTH(Z)>0)
- IF $FIND(Z,"""")>1
- FOR
- IF $FIND(Z,"""")'>1
- QUIT
- SET Z=$TRANSLATE(Z,"""","^")
- +3 FOR
- IF '$LENGTH(Z)
- QUIT
- Begin DoDot:1
- +4 IF $LENGTH(Z)<Y
- SET $EXTRACT(PSBRPLN(J),X)=Z
- SET Z=""
- QUIT
- +5 FOR PSB=Y:-1:0
- IF $EXTRACT(Z,PSB)=" "
- QUIT
- +6 IF PSB<1
- SET PSB=Y
- +7 SET $EXTRACT(PSBRPLN(J),X)=$EXTRACT(Z,1,PSB)
- +8 IF $LENGTH(PSBRPLN(J),"^")>1
- FOR X=1:1:$LENGTH(PSBRPLN(J),"^")-1
- SET $PIECE(PSBRPLN(J),"^",X)=$PIECE(PSBRPLN(J),"^",X)_""""
- +9 SET PSBRPLN(J)=$TRANSLATE(PSBRPLN(J),"^","""")
- +10 SET Z=$EXTRACT(Z,PSB+1,250)
- SET J=J+1
- SET J(J)=""
- End DoDot:1
- +11 QUIT ""
- LSTX(P,O) ;
- +1 SET DT=$$FMDIFF^XLFDT(O,P,2)
- +2 IF ((DT\60)<1)
- QUIT "0d 0h 1m"
- +3 SET D=(DT\(60*60*24))
- SET DT=DT-(D*(60*60*24))
- +4 SET H=(DT\(60*60))
- SET DT=DT-(H*(60*60))
- +5 SET M=((DT+30)\(60))
- SET DT=DT-(M*(60))
- +6 QUIT D_"d "_H_"h "_M_"m"