- PSBOCE ;BIRMINGHAM/TEJ-Expired/DC'd/EXPIRING ORDERS 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.
- ;
- EN ;
- N PSBX1X,RESULTS,RESULT,PSBFUTR
- S PSBFUTR=$TR(PSBRPT(1),"~",U)
- S (PSBOCRIT,PSBXFLG,PSBCFLG)="" ; Ord Status srch crit - "A"ctve, "D"C ed, "E"xpred"
- S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_"Expired/DC'd" S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_"Expired/DC'd" S:$P(PSBFUTR,U,9) PSBOCRIT=PSBOCRIT_"Expiring Today"
- S:$P(PSBFUTR,U,10) PSBOCRIT=PSBOCRIT_"Expiring Tomorrow"
- 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("Expiring Tomorrow"),PSBLIST2("Expiring Today"),PSBLIST2("Expired/DC'd"),PSBLIST2(" * NO * "))=0
- .F S PSBX2X=$O(PSBDATA(PSBX2X)) Q:+PSBX2X=0 D
- ..S PSBDATA=PSBDATA(PSBX2X)
- ..I $P(PSBDATA,U)="ORD" D Q
- ...K PSBDRUGN
- ...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 PSBSTS=$P(PSBDATA,U,23) S PSBSTS=$S((PSBSTS="A")&(($P(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS="H":"On Hold",PSBSTS="D":"Discontinued",PSBSTS="DE":"Discontinued (Edit)",(PSBSTS="E")!($P(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ERROR * ")
- ...S PSBSTS(PSBORDN,PSBSTS)=""
- ...S X2=$P(PSBDATA,U,27),X3=$P(PSBNOWX,".")
- ...S PSBSTSX=$S((X2<PSBNOWX):"Expired/DC'd",(X3'>X2)&($$FMADD^XLFDT(X3,1)>X2):"Expiring Today",($$FMADD^XLFDT(X3,1)'>X2)&(X2'>$$FMADD^XLFDT(X3,2)):"Expiring Tomorrow",1:" * NO * ")
- ...I PSBSTS["Discontinued" S PSBSTSX="Expired/DC'd"
- ...S PSBLIST2(PSBSTSX,$P(PSBDATA,U,9),PSBORDN)="" S PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
- ...S:PSBOCRIT[PSBSTSX PSBTOT=PSBTOT+1
- ...S PSBSCHTY=$P(PSBDATA,U,6)
- ...S PSBSCHTY(PSBORDN,PSBSCHTY)=""
- ...S PSBSCHD=$P(PSBDATA,U,7) I PSBSCHD="" S PSBSCHD=" "
- ...S PSBSCHD(PSBORDN,PSBSCHD)=""
- ...S PSBDOSR=$P(PSBDATA,U,10)_", "_$P(PSBDATA,U,11)
- ...S PSBDOSR=$TR($E(PSBDOSR,1)," ")_$E(PSBDOSR,2,999)
- ...S PSBDOSR(PSBORDN,PSBDOSR)="" K PSBOMDR(PSBORDN)
- ...S PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
- ...I PSBSTS["Hold" S PSBNXTX2="Provider Hold"
- ...I PSBSTS'["Hold" D
- ....I PSBNOWX>$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT) S PSBNXTX2="MISSED "_PSBNXTX1
- ....E S PSBNXTX2="DUE "_PSBNXTX1
- ...S PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
- ...I ("^P^OC^O"[(U_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired") S:PSBSTS'["Hold" PSBNXTX2=" "
- ...S PSBNXTX(PSBORDN,PSBNXTX2)=""
- ...; ** SPC INSTR **
- ...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)=""
- ..I "^DD^ADD^SOL"[(U_$P(PSBDATA,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
- ..I $P(PSBDATA(PSBX2X+1),U)="ORF" D Q
- ...S PSBX2X=PSBX2X+1 S PSBDATA=PSBDATA(PSBX2X)
- ...S:$P(PSBDATA,U,2)]"" PSBFLGD(PSBORDN,$P(PSBDATA,U,3)_" - "_$P(PSBDATA,U,4))=""
- ..I ($P(PSBDATA,U)="ADM")&($P(PSBDATA,U,4)]"") D
- ...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))=""
- ...K PSBDATA(PSBX2X)
- ...I ($P(PSBDATA(PSBX2X+1),U)="CMT") F S PSBDATA=PSBDATA(PSBX2X+1) Q:($P(PSBDATA,U)'="CMT") D
- ....S PSBX2X=PSBX2X+1
- ....S PSBDATA=PSBDATA(PSBX2X)
- ....K PSBDATA(PSBX2X)
- ....S:$P(PSBDATA,U,3)]"" PSBPRNEF(PSBORDN,$P(PSBXID,U,2))=$P(PSBDATA,U,3)
- ....I 'PSBCFLG S PSBDATA=PSBDATA(PSBX2X+1) Q
- ....I $P(PSBDATA,U,2)'="" D
- .....S PSBLGD(PSBORDN,"C","INITIALS",$P(PSBDATA,U,4))=""
- .....S PSBCMT(PSBORDN,$P(PSBXID,U,2),(-1*$P(PSBDATA,U,6)),PSBX2X)=PSBDATA
- I '$D(PSBLIST2) K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
- D CREATHDR
- D SUBHDR
- D BLDRPT
- D WRTRPT
- Q
- BLDRPT ; Buld RPT DATA
- S X0="" K PSBLIST2(" * NO * "),PSBL2ULN
- S PSBTOPHD=PSBLNTOT-2
- I '$D(PSBLIST2) D Q
- .S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
- S PSBMORE=5 F PSBX1X="Expired/DC'd","Expiring Today","Expiring Tomorrow" 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'[PSBX1X
- .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="" 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(PSBSCHD(PSBX2X,""))
- ..S PSBDATA(1,6)=$O(PSBNXTX(PSBX2X,""))
- ..S:PSBDATA(1,6)'["Hold" $P(PSBDATA(1,6)," ",2)=$$FMTDT^PSBOCE1($P(PSBDATA(1,6)," ",2))
- ..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^PSBOCE1,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,PSBSILN
- D:+PSBTOT>0 LGD^PSBOCM
- Q
- WRTRPT ; writ
- I $O(PSBOUTP(""),-1)<1 D Q
- .X PSBOUTP($O(PSBOUTP(""),-1),21)
- .D FTR
- S PSBPGNUM=1
- S PSBZ="" F S PSBZ=$O(PSBOUTP(PSBZ)) Q:PSBZ="" D
- .I PSBPGNUM'=PSBZ D FTR S PSBPGNUM=PSBZ D HDR,SUBHDR
- .S PSBX2X="" F S PSBX2X=$O(PSBOUTP(PSBZ,PSBX2X)) Q:PSBX2X="" D
- ..X PSBOUTP(PSBZ,PSBX2X)
- D FTR
- K ^XTMP("PSBO",$J,"PSBLIST"),PSBOUTP
- Q
- HDR ; Hder
- W:$Y>1 @IOF
- W:$X>1 !
- S PSBRPNM="BCMA COVERSHEET EXPIRED/DC'd/EXPIRING ORDERS REPORT"
- D:$P(PSBRPT(.1),U,1)="P"
- .S PSBHDR(0)=PSBRPNM
- .S PSBHDR(1)="Order Status(es): --"
- .F Y=7,8,9,10 I $P(PSBFUTR,U,Y) S $P(PSBHDR(1),": ",2)=$P(PSBHDR(1),": ",2)_$S(PSBHDR(1)["--":"",1:"/ ")_$P("^^^^^^Expired^DC'd^Expiring Today^Expiring Tomorrow^^^^^^^^",U,Y)_" " S PSBHDR(1)=$TR(PSBHDR(1),"-","")
- .I $P(PSBFUTR,U,11) S PSBHDR(2)="Include Action(s)"_$S(PSBCFLG:" & Comments/Reasons",1:"")
- .D PT^PSBOHDR(PSBXDFN,.PSBHDR)
- Q
- SUBHDR ;
- N PSBAL S PSBAL=$O(PSBHDR("ALERGY",""),-1) S PSBAL=$S((PSBAL/12)>(PSBAL\12):(PSBAL\12)+1,1:(PSBAL\12))
- N PSBRE S PSBRE=$O(PSBHDR("REAC",""),-1) S PSBRE=$S((PSBRE/12)>(PSBRE\12):(PSBRE\12)+1,1:(PSBRE\12))
- S PSBLNTOT=$O(PSBHDR(""),-1)+9+PSBAL+PSBRE+1
- I $G(PSBPGNUM,0)=1 W !,?(PSBTAB8-($L("Total Orders reported: "_+PSBTOT))),"Total Orders reported: "_+PSBTOT,! S PSBLNTOT=PSBLNTOT+2
- W !,$TR($J("",PSBTAB8)," ","_") S PSBLNTOT=PSBLNTOT+1
- W !,$G(PSBHD1,"") S PSBLNTOT=PSBLNTOT+1
- W !,$G(PSBHD2,"") S PSBLNTOT=PSBLNTOT+1
- W !,$TR($J("",PSBTAB8)," ","="),! S PSBLNTOT=PSBLNTOT+2
- I $D(NOTE(PSBPGNUM)) W NOTE(PSBPGNUM),!! S PSBLNTOT=PSBLNTOT+2
- Q
- FTR ; Footr
- D PTFTR^PSBOHDR()
- S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
- S PSBPGRM=PSBTAB8-($L(PSBPG))
- W !,PSBRPNM," ",?(PSBPGRM-($L(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
- 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
- CREATHDR ;
- K PSBHD1,PSBHD2
- I IOM'<132 S PSBMORE=4,PSBHD1=$P($T(HD132A),"~",2),PSBHD2=$P($T(HD132B),";",2),PSBBLANK=$P($T(H132BLK),";",2)
- E S PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY" K PSBLIST2 Q
- ; tabs
- S PSBTAB0=1 F PSBI=0:1:($L(PSBHD1,"|")-1) S:PSBI>0 @("PSBTAB"_PSBI)=($F(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
- S PSBPGNUM=1
- D HDR
- Q
- HD132A ;~ VDL | Status |Type| Medication; Dosage, Route | Schedule | Next | Order Start | Order Stop |
- Q
- HD132B ; Tab | | | | | Action | Date | Date |
- Q
- H132BLK ;; | | | | | | | |
- Q
- PSBOCE ;BIRMINGHAM/TEJ-Expired/DC'd/EXPIRING ORDERS 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 ;
- EN ;
- +1 NEW PSBX1X,RESULTS,RESULT,PSBFUTR
- +2 SET PSBFUTR=$TRANSLATE(PSBRPT(1),"~",U)
- +3 ; Ord Status srch crit - "A"ctve, "D"C ed, "E"xpred"
- SET (PSBOCRIT,PSBXFLG,PSBCFLG)=""
- +4 IF $PIECE(PSBFUTR,U,7)
- SET PSBOCRIT=PSBOCRIT_"Expired/DC'd"
- IF $PIECE(PSBFUTR,U,8)
- SET PSBOCRIT=PSBOCRIT_"Expired/DC'd"
- IF $PIECE(PSBFUTR,U,9)
- SET PSBOCRIT=PSBOCRIT_"Expiring Today"
- +5 IF $PIECE(PSBFUTR,U,10)
- SET PSBOCRIT=PSBOCRIT_"Expiring Tomorrow"
- +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("Expiring Tomorrow"),PSBLIST2("Expiring Today"),PSBLIST2("Expired/DC'd"),PSBLIST2(" * NO * "))=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"
- Begin DoDot:3
- +29 KILL PSBDRUGN
- +30 SET PSBORDN=$PIECE(PSBDATA,U,3)
- +31 SET PSBTB=$PIECE(PSBDATA,U,29)
- SET PSBTB=$SELECT(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
- +32 SET PSBTB(PSBORDN,PSBTB)=""
- +33 SET PSBSTS=$PIECE(PSBDATA,U,23)
- SET PSBSTS=$SELECT((PSBSTS="A")&(($PIECE(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS="H":"On Hold",PSBSTS="D":"Discontinued",PSBSTS="DE":"Discontinued (Edit)",(PSBSTS="E")!($PIECE(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ERRO
- R * ")
- +34 SET PSBSTS(PSBORDN,PSBSTS)=""
- +35 SET X2=$PIECE(PSBDATA,U,27)
- SET X3=$PIECE(PSBNOWX,".")
- +36 SET PSBSTSX=$SELECT((X2<PSBNOWX):"Expired/DC'd",(X3'>X2)&($$FMADD^XLFDT(X3,1)>X2):"Expiring Today",($$FMADD^XLFDT(X3,1)'>X2)&(X2'>$$FMADD^XLFDT(X3,2)):"Expiring Tomorrow",1:" * NO * ")
- +37 IF PSBSTS["Discontinued"
- SET PSBSTSX="Expired/DC'd"
- +38 SET PSBLIST2(PSBSTSX,$PIECE(PSBDATA,U,9),PSBORDN)=""
- SET PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
- +39 IF PSBOCRIT[PSBSTSX
- SET PSBTOT=PSBTOT+1
- +40 SET PSBSCHTY=$PIECE(PSBDATA,U,6)
- +41 SET PSBSCHTY(PSBORDN,PSBSCHTY)=""
- +42 SET PSBSCHD=$PIECE(PSBDATA,U,7)
- IF PSBSCHD=""
- SET PSBSCHD=" "
- +43 SET PSBSCHD(PSBORDN,PSBSCHD)=""
- +44 SET PSBDOSR=$PIECE(PSBDATA,U,10)_", "_$PIECE(PSBDATA,U,11)
- +45 SET PSBDOSR=$TRANSLATE($EXTRACT(PSBDOSR,1)," ")_$EXTRACT(PSBDOSR,2,999)
- +46 SET PSBDOSR(PSBORDN,PSBDOSR)=""
- KILL PSBOMDR(PSBORDN)
- +47 SET PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
- +48 IF PSBSTS["Hold"
- SET PSBNXTX2="Provider Hold"
- +49 IF PSBSTS'["Hold"
- Begin DoDot:4
- +50 IF PSBNOWX>$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT)
- SET PSBNXTX2="MISSED "_PSBNXTX1
- +51 IF '$TEST
- SET PSBNXTX2="DUE "_PSBNXTX1
- End DoDot:4
- +52 SET PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
- +53 IF ("^P^OC^O"[(U_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired")
- IF PSBSTS'["Hold"
- SET PSBNXTX2=" "
- +54 SET PSBNXTX(PSBORDN,PSBNXTX2)=""
- +55 ; ** SPC INSTR **
- +56 SET PSBX2X=PSBX2X+1
- +57 SET PSBSI=$PIECE(PSBDATA(PSBX2X),U,2)
- +58 IF PSBSI]" "
- SET PSBSI(PSBORDN,PSBSI)=""
- +59 SET PSBOSTDT=$PIECE(PSBDATA,U,22)
- +60 SET PSBOSTDT(PSBORDN,PSBOSTDT)=""
- +61 SET PSBOSPDT=$PIECE(PSBDATA,U,27)
- +62 SET PSBOSPDT(PSBORDN,PSBOSPDT)=""
- End DoDot:3
- QUIT
- +63 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA,U))
- Begin DoDot:3
- +64 FOR I=PSBX2X:1
- SET PSBDATA1=PSBDATA(I)
- Begin DoDot:4
- +65 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA1,U))
- SET PSBX2X=I
- SET PSBDRUGN=$GET(PSBDRUGN,"")_$PIECE(PSBDATA1,U,3)_", "
- QUIT
- +66 SET $EXTRACT(PSBDRUGN,$LENGTH(PSBDRUGN)-1)=""
- SET PSBDRUGN(PSBORDN,$EXTRACT(PSBDRUGN,1,250))=PSBDRUGN
- +67 SET PSBOMDR(PSBORDN,$EXTRACT((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
- End DoDot:4
- IF $DATA(PSBOMDR(PSBORDN))
- QUIT
- End DoDot:3
- QUIT
- +68 IF $PIECE(PSBDATA,U)="END"
- QUIT
- +69 IF $PIECE(PSBDATA(PSBX2X+1),U)="ORF"
- Begin DoDot:3
- +70 SET PSBX2X=PSBX2X+1
- SET PSBDATA=PSBDATA(PSBX2X)
- +71 IF $PIECE(PSBDATA,U,2)]""
- SET PSBFLGD(PSBORDN,$PIECE(PSBDATA,U,3)_" - "_$PIECE(PSBDATA,U,4))=""
- End DoDot:3
- QUIT
- +72 IF ($PIECE(PSBDATA,U)="ADM")&($PIECE(PSBDATA,U,4)]"")
- Begin DoDot:3
- +73 SET PSBXID=$PIECE(PSBDATA,U,6)_U_$PIECE(PSBDATA,U,4)
- SET PSBADM(PSBORDN,(-1*($PIECE(PSBDATA,U,6))),PSBXID)=PSBDATA
- +74 IF $ORDER(PSBSCHTY(PSBORDN,""))="P"
- SET PSBPRNR(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,9)
- +75 IF $PIECE(PSBDATA,U,3)]""
- SET PSBBID(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,3)
- +76 IF PSBXFLG
- SET PSBLGD(PSBORDN,"X","INITIALS",$PIECE(PSBDATA,U,8))=""
- +77 KILL PSBDATA(PSBX2X)
- +78 IF ($PIECE(PSBDATA(PSBX2X+1),U)="CMT")
- FOR
- SET PSBDATA=PSBDATA(PSBX2X+1)
- IF ($PIECE(PSBDATA,U)'="CMT")
- QUIT
- Begin DoDot:4
- +79 SET PSBX2X=PSBX2X+1
- +80 SET PSBDATA=PSBDATA(PSBX2X)
- +81 KILL PSBDATA(PSBX2X)
- +82 IF $PIECE(PSBDATA,U,3)]""
- SET PSBPRNEF(PSBORDN,$PIECE(PSBXID,U,2))=$PIECE(PSBDATA,U,3)
- +83 IF 'PSBCFLG
- SET PSBDATA=PSBDATA(PSBX2X+1)
- QUIT
- +84 IF $PIECE(PSBDATA,U,2)'=""
- Begin DoDot:5
- +85 SET PSBLGD(PSBORDN,"C","INITIALS",$PIECE(PSBDATA,U,4))=""
- +86 SET PSBCMT(PSBORDN,$PIECE(PSBXID,U,2),(-1*$PIECE(PSBDATA,U,6)),PSBX2X)=PSBDATA
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +87 IF '$DATA(PSBLIST2)
- KILL PSBLIST,^XTMP("PSBO",$JOB,"PSBLIST")
- +88 DO CREATHDR
- +89 DO SUBHDR
- +90 DO BLDRPT
- +91 DO WRTRPT
- +92 QUIT
- BLDRPT ; Buld RPT DATA
- +1 SET X0=""
- KILL PSBLIST2(" * NO * "),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="Expired/DC'd","Expiring Today","Expiring Tomorrow"
- 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'[PSBX1X
- 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
- 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(PSBSCHD(PSBX2X,""))
- +21 SET PSBDATA(1,6)=$ORDER(PSBNXTX(PSBX2X,""))
- +22 IF PSBDATA(1,6)'["Hold"
- SET $PIECE(PSBDATA(1,6)," ",2)=$$FMTDT^PSBOCE1($PIECE(PSBDATA(1,6)," ",2))
- +23 SET PSBDATA(1,7)=$$FMTDT^PSBOCE1($ORDER(PSBOSTDT(PSBX2X,"")))
- +24 SET PSBDATA(1,8)=$$FMTDT^PSBOCE1($EXTRACT($ORDER(PSBOSPDT(PSBX2X,"")),1,12))
- +25 SET PSBSIDAT(1)=$ORDER(PSBSI(PSBX2X,""))
- +26 SET PSBTOT1=PSBTOT1+1
- +27 KILL PSBDATA(2),PSBDATA(3),PSBSILN
- +28 DO BUILDLN^PSBOCE1
- DO SIOPI^PSBOCM(.PSBSIDAT,PSBTAB8,$SELECT(PSBX2X["V":"Other Print Info:",1:""))
- +29 IF $DATA(PSBRPLN)
- SET PSBMORE=$ORDER(PSBRPLN(""),-1)+6
- IF $DATA(PSBSILN)
- SET PSBMORE=PSBMORE+$ORDER(PSBSILN(""),-1)
- +30 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
- +31 SET PSBCNT=PSBTOT1_" "_$GET(PSB1,"")
- +32 SET PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
- +33 SET I=""
- FOR
- SET I=$ORDER(PSBRPLN(I))
- IF +I=0
- QUIT
- Begin DoDot:3
- +34 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
- End DoDot:3
- +35 SET I=""
- FOR
- SET I=$ORDER(PSBSILN(I))
- IF +I=0
- QUIT
- Begin DoDot:3
- +36 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
- End DoDot:3
- +37 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
- +38 KILL PSBRPLN,PSBDATA,PSBSILN
- End DoDot:2
- End DoDot:1
- +39 IF +PSBTOT>0
- DO LGD^PSBOCM
- +40 QUIT
- WRTRPT ; writ
- +1 IF $ORDER(PSBOUTP(""),-1)<1
- Begin DoDot:1
- +2 XECUTE PSBOUTP($ORDER(PSBOUTP(""),-1),21)
- +3 DO FTR
- End DoDot:1
- QUIT
- +4 SET PSBPGNUM=1
- +5 SET PSBZ=""
- FOR
- SET PSBZ=$ORDER(PSBOUTP(PSBZ))
- IF PSBZ=""
- QUIT
- Begin DoDot:1
- +6 IF PSBPGNUM'=PSBZ
- DO FTR
- SET PSBPGNUM=PSBZ
- DO HDR
- DO SUBHDR
- +7 SET PSBX2X=""
- FOR
- SET PSBX2X=$ORDER(PSBOUTP(PSBZ,PSBX2X))
- IF PSBX2X=""
- QUIT
- Begin DoDot:2
- +8 XECUTE PSBOUTP(PSBZ,PSBX2X)
- End DoDot:2
- End DoDot:1
- +9 DO FTR
- +10 KILL ^XTMP("PSBO",$JOB,"PSBLIST"),PSBOUTP
- +11 QUIT
- HDR ; Hder
- +1 IF $Y>1
- WRITE @IOF
- +2 IF $X>1
- WRITE !
- +3 SET PSBRPNM="BCMA COVERSHEET EXPIRED/DC'd/EXPIRING ORDERS REPORT"
- +4 IF $PIECE(PSBRPT(.1),U,1)="P"
- Begin DoDot:1
- +5 SET PSBHDR(0)=PSBRPNM
- +6 SET PSBHDR(1)="Order Status(es): --"
- +7 FOR Y=7,8,9,10
- IF $PIECE(PSBFUTR,U,Y)
- SET $PIECE(PSBHDR(1),": ",2)=$PIECE(PSBHDR(1),": ",2)_$SELECT(PSBHDR(1)["--":"",1:"/ ")_$PIECE("^^^^^^Expired^DC'd^Expiring Today^Expiring Tomorrow^^^^^^^^",U,Y)_" "
- SET PSBHDR(1)=$TRANSLATE(PSBHDR(1),"-","")
- +8 IF $PIECE(PSBFUTR,U,11)
- SET PSBHDR(2)="Include Action(s)"_$SELECT(PSBCFLG:" & Comments/Reasons",1:"")
- +9 DO PT^PSBOHDR(PSBXDFN,.PSBHDR)
- End DoDot:1
- +10 QUIT
- SUBHDR ;
- +1 NEW PSBAL
- SET PSBAL=$ORDER(PSBHDR("ALERGY",""),-1)
- SET PSBAL=$SELECT((PSBAL/12)>(PSBAL\12):(PSBAL\12)+1,1:(PSBAL\12))
- +2 NEW PSBRE
- SET PSBRE=$ORDER(PSBHDR("REAC",""),-1)
- SET PSBRE=$SELECT((PSBRE/12)>(PSBRE\12):(PSBRE\12)+1,1:(PSBRE\12))
- +3 SET PSBLNTOT=$ORDER(PSBHDR(""),-1)+9+PSBAL+PSBRE+1
- +4 IF $GET(PSBPGNUM,0)=1
- WRITE !,?(PSBTAB8-($LENGTH("Total Orders reported: "_+PSBTOT))),"Total Orders reported: "_+PSBTOT,!
- SET PSBLNTOT=PSBLNTOT+2
- +5 WRITE !,$TRANSLATE($JUSTIFY("",PSBTAB8)," ","_")
- SET PSBLNTOT=PSBLNTOT+1
- +6 WRITE !,$GET(PSBHD1,"")
- SET PSBLNTOT=PSBLNTOT+1
- +7 WRITE !,$GET(PSBHD2,"")
- SET PSBLNTOT=PSBLNTOT+1
- +8 WRITE !,$TRANSLATE($JUSTIFY("",PSBTAB8)," ","="),!
- SET PSBLNTOT=PSBLNTOT+2
- +9 IF $DATA(NOTE(PSBPGNUM))
- WRITE NOTE(PSBPGNUM),!!
- SET PSBLNTOT=PSBLNTOT+2
- +10 QUIT
- FTR ; Footr
- +1 DO PTFTR^PSBOHDR()
- +2 SET PSBPG="Page: "_PSBPGNUM_" of "_$SELECT($ORDER(PSBOUTP(""),-1)=0:1,1:$ORDER(PSBOUTP(""),-1))
- +3 SET PSBPGRM=PSBTAB8-($LENGTH(PSBPG))
- +4 WRITE !,PSBRPNM," ",?(PSBPGRM-($LENGTH(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
- +5 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
- CREATHDR ;
- +1 KILL PSBHD1,PSBHD2
- +2 IF IOM'<132
- SET PSBMORE=4
- SET PSBHD1=$PIECE($TEXT(HD132A),"~",2)
- SET PSBHD2=$PIECE($TEXT(HD132B),";",2)
- SET PSBBLANK=$PIECE($TEXT(H132BLK),";",2)
- +3 IF '$TEST
- SET PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY"
- KILL PSBLIST2
- QUIT
- +4 ; tabs
- +5 SET PSBTAB0=1
- FOR PSBI=0:1:($LENGTH(PSBHD1,"|")-1)
- IF PSBI>0
- SET @("PSBTAB"_PSBI)=($FIND(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
- +6 SET PSBPGNUM=1
- +7 DO HDR
- +8 QUIT
- HD132A ;~ VDL | Status |Type| Medication; Dosage, Route | Schedule | Next | Order Start | Order Stop |
- +1 QUIT
- HD132B ; Tab | | | | | Action | Date | Date |
- +1 QUIT
- H132BLK ;; | | | | | | | |
- +1 QUIT