- PSBOCM ;BIRMINGHAM/TEJ-OVERSHEET MEDICATION OVERVIEW REPORT ;03/06/16 3:06pm
- ;;3.0;BAR CODE MED ADMIN;**32,50,68,70,83,139**;Mar 2004;Build 1
- ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
- ;
- ; Reference/IA
- ; File 4/10090
- ; File 200/10060
- ; GETSIOPI^PSJBCMA5/5763
- ;
- ;*68 - allow SIOPI builder to accomodate more than 1 line in SI array
- ;*70 - pass global var PSBCLINORD when Rpc Psbcsutl is called again
- ; - add clinic name to new array PSBCLIN to track clinic name per
- ; order for printed output.
- ; - 1512: Don't show the Special Instructions / Other Print Info
- ; unless radio button selected.
- ; - convert date/time fields to date only for CO and admin window
- ; to 7 days +/-.
- ;*83 - add Removes as new event for Next Action column:
- ; Remove date@time
- ; Missed date@time
- ; (Remove)
- ;*139 - Prevent null subscript error when variable PSBNXTX2 (for the next
- ; administration time) is never reset to a value.
- ;
- EN ;
- N PSBX1X,RESULTS,RESULT,PSBFUTR,QQ,PSBCLIN,PSBSRCHL,STRTDT,STOPDT,EXPIREHDG,REMOV,PSBNXTX,PSBNXTX1,PSBNXTX2 ;*83
- 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
- S PSBCLINORD=$S($P($G(PSBRPT(4)),U,2)="C":1,1:0) ;*70
- ;add ability to use a different heading for expired IM/CO meds ;*70
- S EXPIREHDG=$S(PSBCLINORD:"EXPIRED/DC'd within last 7 days",1:"EXPIRED/DC'd")
- ;
- S PSBFUTR=$TR(PSBRPT(1),"~",U)
- ;check Clinic search list ;*70
- S PSBSRCHL=$$SRCHLIST^PSBOHDR()
- D:$P(PSBRPT(4),U,2)="C"
- .S:PSBSRCHL="" PSBSRCHL="All Clinics"
- .S PSBSRCHL="Clinic Search List: "_PSBSRCHL
- ;
- K PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD,PSBHDR,PSBSTS
- S PSBSORT=1
- D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=$E(Y,1,18)
- 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)
- ;change admin window times to 7 days for CO
- I PSBCLINORD S (PSBB4,PSBAFT)=7
- 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,,,PSBCLINORD) ;*70
- .M PSBDATA=@PSBAREA
- .D GETREMOV^PSBO1(PSBXDFN) ;get all removes for this patient *83
- .S PSBX2X=1
- .S PSBLIST2("ACTIVE")=0,PSBLIST2("FUTURE")=0,PSBLIST2(EXPIREHDG)=0,PSBLIST2(" * ERROR * ")=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 PSBCLIN(PSBORDN)=$S($P(PSBDATA,U,32)]"":"Location: ",1:"")_$P(PSBDATA,U,32) ;*70
- ...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 STRTDT=$P(PSBDATA,U,22),STOPDT=$P(PSBDATA,U,27) ;*70
- ...S PSBSTSX=$S(STOPDT'>PSBNOWX:EXPIREHDG,$$FMADD^XLFDT(STRTDT,,,-PSBB4)'>PSBNOWX:"ACTIVE",STRTDT>$$FMADD^XLFDT(PSBNOWX,,,PSBB4):"FUTURE",1:" * ERROR * ") ;*70
- ...;
- ...S PSBLIST2(PSBSTSX,$P(PSBDATA,U,9),PSBORDN)="" S PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
- ...S:PSBOCRIT[$E(PSBSTSX,1) PSBTOT=PSBTOT+1
- ...S PSBSCHTY=$P(PSBDATA,U,6)
- ...I PSBTB="IV" S PSBSCHTY=" "
- ...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)="" K PSBOMDR(PSBORDN)
- ...S PSBSCHD=$P(PSBDATA,U,7) I PSBSCHD="" S PSBSCHD=" "
- ...S PSBSCHD(PSBORDN,PSBSCHD)=""
- ...S PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
- ...S PSBNXTX2="" ;init *83
- ...I PSBSTS["Hold" S PSBNXTX2="Provider Hold"
- ...;
- ...;Next admin date triggers data for Next Action col, and also *83
- ...; if a remove action is pending use that text for NA col. *83
- ...S REMOV=$O(^TMP("PSB",$J,"RM","B",PSBORDN,0))
- ...I PSBSTS'["Hold",((PSBNXTX1)!(REMOV)) D
- ....;build Admin Next Action text
- ....D:PSBNXTX1
- .....S NXTADM=$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT)
- .....S PSBNXTX2=$S(PSBNOWX>NXTADM:"MISSED ",1:"DUE ")_PSBNXTX1
- ....;Removal tests and Next Action text build *83
- ....S REMOV=$O(^TMP("PSB",$J,"RM","B",PSBORDN,0))
- ....D:REMOV
- .....S MRR=$P(PSBDATA(PSBX2X),U,35)
- .....S RMVTIM=$P(^TMP("PSB",$J,"RM",REMOV),U)
- .....;Sched types below have no admin nor removal times, but do know
- .....; this MRR was given and next is Removal
- .....I ("^P^OC^"[("^"_PSBSCHTY_"^")) S:PSBSTS'["Hold" PSBNXTX2="(Removal)" Q
- .....;sys err tst, sched rmv dt/tm empty, if null use nxt adm for rmv
- .....I MRR=1,'RMVTIM S RMVTIM=PSBNXTX1
- .....I PSBNOWX>$$FMADD^XLFDT(RMVTIM,,,PSBAFT) D ;missed rm
- ......S PSBNXTX2="MISSED "_RMVTIM_" (Removal)"
- ......S:'RMVTIM PSBNXTX2="REMOVE" ;err, rmv empty
- .....E D ;due rm
- ......S PSBNXTX2="REMOVE "_RMVTIM
- .....K MRR,NXTADM,RMVTIM
- ...;
- ...S PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
- ...;don't do if Expired Next action is a Removal *83
- ...I PSBNXTX2'["Removal",PSBNXTX2'["REMOVE" D
- ....I ("^P^OC^O"[("^"_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired") S:PSBSTS'["Hold" PSBNXTX2=" "
- ...S:PSBNXTX2="" PSBNXTX2=" " ; *139
- ...S PSBNXTX(PSBORDN,PSBNXTX2)=""
- ...; ** SPECIAL INSTRUCTIONS **
- ...S PSBX2X=PSBX2X+1
- ...; *68
- ...K ^TMP("PSJBCMA5",$J)
- ...I PSBSIFLG D GETSIOPI^PSJBCMA5(PSBX1X,PSBORDN,1)
- ...F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,PSBX1X,PSBORDN,QQ)) Q:'QQ D
- ....S PSBSI(PSBORDN,QQ)=^TMP("PSJBCMA5",$J,PSBX1X,PSBORDN,QQ)
- ...; *68 end
- ...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(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
- ..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))=""
- ..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
- ...S PSBTEST="" F S PSBTEST=$O(PSBFLGD(PSBORDN,PSBTEST)) Q:PSBTEST="" I $P(PSBTEST,":")="NOX" K PSBFLGD(PSBORDN,PSBTEST) Q
- ...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 +PSBTOT=0 K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
- D CREATHDR^PSBOCM1
- D SUBHDR^PSBOCE
- D BLDRPT
- D WRTRPT^PSBOCM1
- K ^TMP("PSJBCMA5",$J) ;*68
- Q
- BLDRPT ; Build REPORT DATA
- S PSBTOPHD=PSBLNTOT-2
- K PSBL2ULN
- I '$D(PSBLIST2) D Q
- .S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
- S PSBMORE=5 F PSBX1X="ACTIVE","FUTURE",EXPIREHDG," * 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(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))
- ..K PSBSIDAT M PSBSIDAT=PSBSI(PSBX2X) ;*68
- ..S PSBTOT1=PSBTOT1+1
- ..K PSBDATA(2),PSBDATA(3),PSBSILN
- ..D BUILDLN^PSBOCM1,SIOPI(.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,X 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
- ..;*70 build write clinic stmt
- ..S PSBOUTP($$PGTOT,PSBLNTOT)="W """_$G(PSBCLIN(PSBX2X))_""""_",!"
- ..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
- 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
- SIOPI(PSBXSI,TAB,Y) ;create SIOPI text
- ; *68 - modified this tag to handle only WP extra lines
- I '$P(PSBRPT(4),U) Q ;[*70-1512]
- Q:$O(PSBXSI(""))=""
- ;
- N X,LBL,LBLLN,RMAR,TXT
- I $G(Y)="" S Y="Special Instructions: "
- ; build label for SI field, then check $L to make a right margin
- S LBL=" "_Y
- S LBLLN=$L(LBL),RMAR="",$P(RMAR," ",LBLLN+1)="" ;make margin of " "
- K J,TXT,TXT1,TXT2 S J(0)=""
- S J=($O(J(""),-1)+1) S PSBSILN(J)="",J(J)="" S J=($O(J(""),-1)+1)
- F X=0:0 S X=$O(PSBXSI(X)) Q:'X D
- .I X=1 S TXT=LBL_PSBXSI(X) ;put label & 1st line together
- .E S TXT=RMAR_PSBXSI(X) ;all other lines add rmar
- .S TXT1=TXT
- .I ($L(TXT1)>0),$F(TXT1,"""")>1 D
- ..S TXT1=$TR(TXT1,"""","^")
- ..I $L(TXT1)+5'<TAB S TXT2=$E(TXT1,TAB-9,999),TXT1=$E(TXT1,1,TAB-10)
- ..I $L(TXT1,"^")>1 F Y=1:1:$L(TXT1,"^")-1 S $P(TXT1,"^",Y)=$P(TXT1,"^",Y)_""""
- ..I $D(TXT2) I $L(TXT2,"^")>1 F X=1:1:$L(TXT2,"^")-1 S $P(TXT2,"^",X)=$P(TXT2,"^",X)_""""
- ..S TXT1=$TR(TXT1,"^","""") I $D(TXT2) S TXT2=$TR(TXT2,"^","""")
- .S $E(PSBSILN(J),5,999)=TXT1,J(J)="",J=J+1
- .I $D(TXT2) S $E(PSBSILN(J),5,999)=TXT2,J(J)="",J=J+1
- S $E(PSBSILN(J),3,999)=" ",J(J)="",J=J+1
- Q
- LGD ; Create Report's Legend
- K PSBLGDO
- S PSBLGD("ORDER TYPES","C")="Continuous"
- S PSBLGD("ORDER TYPES","O")="One Time"
- S PSBLGD("ORDER TYPES","OC")="On Call"
- S PSBLGD("ORDER TYPES","P")="PRN"
- S PSB=0 F S PSB=$O(PSBLGD("INITIALS",PSB)) Q:+PSB=0 D
- .S PSBINIT=$$GET1^DIQ(200,PSB_",","INITIAL"),PSBLGD("INITIALS",$S(PSBINIT']" ":"*n/a*",1:PSBINIT))=$$GET1^DIQ(200,PSB_",","NAME")
- .K PSBLGD("INITIALS",PSB)
- S PSBPGNUM=$O(PSBOUTP(""),-1),PSBLGDO(0)="REPORT LEGEND"
- S PSBLGDO(1)=""
- S PSBLGDO(2)=$S($G(PSBNO,0):"",1:"SCHEDULE TYPES")
- S PSBLGDO(3)=""
- I '$G(PSBNO,0) S X1="",X2=3 F S X1=$O(PSBLGD("ORDER TYPES",X1)) Q:X1="" S X2=X2+1,PSBLGDO(X2)=X1,$E(PSBLGDO(X2),5)="- "_PSBLGD("ORDER TYPES",X1)
- I $D(PSBLGD("INITIALS")) S $E(PSBLGDO(2),35)="INITIALS" S X1="",X2=3 F S X1=$O(PSBLGD("INITIALS",X1)) Q:X1="" S X2=X2+1,$E(PSBLGDO(X2),35)=X1,$E(PSBLGDO(X2),40)="- "_PSBLGD("INITIALS",X1)
- S (PSBMORE,X0)=10+($O(PSBLGDO(""),-1))
- I (PSBLNTOT+PSBMORE)'<IOSL S PSBLNTOT=PSBTOPHD-2,PSBPGNUM=PSBPGNUM+1
- I IOSL<1000 S X2=PSBLNTOT F Q:X2'<(IOSL-(X0+3)) S PSBOUTP($$PGTOT,PSBLNTOT)="W !",X2=X2+1
- S PSBMORE=X0
- S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TR($J("",IOM)," ","=")_""",!"
- F X1=0:1 Q:'$D(PSBLGDO(X1)) S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_$G(PSBLGDO(X1)," ")_""""
- S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TR($J("",IOM)," ","=")_""",!"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOCM 13403 printed Feb 18, 2025@23:06:50 Page 2
- PSBOCM ;BIRMINGHAM/TEJ-OVERSHEET MEDICATION OVERVIEW REPORT ;03/06/16 3:06pm
- +1 ;;3.0;BAR CODE MED ADMIN;**32,50,68,70,83,139**;Mar 2004;Build 1
- +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
- +6 ; File 200/10060
- +7 ; GETSIOPI^PSJBCMA5/5763
- +8 ;
- +9 ;*68 - allow SIOPI builder to accomodate more than 1 line in SI array
- +10 ;*70 - pass global var PSBCLINORD when Rpc Psbcsutl is called again
- +11 ; - add clinic name to new array PSBCLIN to track clinic name per
- +12 ; order for printed output.
- +13 ; - 1512: Don't show the Special Instructions / Other Print Info
- +14 ; unless radio button selected.
- +15 ; - convert date/time fields to date only for CO and admin window
- +16 ; to 7 days +/-.
- +17 ;*83 - add Removes as new event for Next Action column:
- +18 ; Remove date@time
- +19 ; Missed date@time
- +20 ; (Remove)
- +21 ;*139 - Prevent null subscript error when variable PSBNXTX2 (for the next
- +22 ; administration time) is never reset to a value.
- +23 ;
- EN ;
- +1 ;*83
- NEW PSBX1X,RESULTS,RESULT,PSBFUTR,QQ,PSBCLIN,PSBSRCHL,STRTDT,STOPDT,EXPIREHDG,REMOV,PSBNXTX,PSBNXTX1,PSBNXTX2
- +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 ;*70
- SET PSBCLINORD=$SELECT($PIECE($GET(PSBRPT(4)),U,2)="C":1,1:0)
- +9 ;add ability to use a different heading for expired IM/CO meds ;*70
- +10 SET EXPIREHDG=$SELECT(PSBCLINORD:"EXPIRED/DC'd within last 7 days",1:"EXPIRED/DC'd")
- +11 ;
- +12 SET PSBFUTR=$TRANSLATE(PSBRPT(1),"~",U)
- +13 ;check Clinic search list ;*70
- +14 SET PSBSRCHL=$$SRCHLIST^PSBOHDR()
- +15 if $PIECE(PSBRPT(4),U,2)="C"
- Begin DoDot:1
- +16 if PSBSRCHL=""
- SET PSBSRCHL="All Clinics"
- +17 SET PSBSRCHL="Clinic Search List: "_PSBSRCHL
- End DoDot:1
- +18 ;
- +19 KILL PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD,PSBHDR,PSBSTS
- +20 SET PSBSORT=1
- +21 DO NOW^%DTC
- SET (Y,PSBNOWX)=%
- DO DD^%DT
- SET PSBDTTM=$EXTRACT(Y,1,18)
- +22 DO GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
- +23 SET PSBB4=0
- if RESULTS(0)>0
- SET PSBB4=+RESULTS(0)
- +24 DO GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
- +25 SET PSBAFT=0
- if RESULTS(0)>0
- SET PSBAFT=+RESULTS(0)
- +26 ;change admin window times to 7 days for CO
- +27 IF PSBCLINORD
- SET (PSBB4,PSBAFT)=7
- +28 KILL ^XTMP("PSBO",$JOB,"PSBLIST")
- +29 SET (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
- +30 KILL PSBLIST,PSBLIST2
- +31 SET PSBXDFN=$PIECE(PSBRPT(.1),U,2)
- +32 SET PSBLIST(PSBXDFN)=""
- +33 SET (PSBX1X,PSBTOT)=0
- +34 FOR
- SET PSBX1X=$ORDER(PSBLIST(PSBX1X))
- if +PSBX1X=0
- QUIT
- Begin DoDot:1
- +35 ;*70
- DO RPC^PSBCSUTL(.PSBAREA,PSBX1X,,,PSBCLINORD)
- +36 MERGE PSBDATA=@PSBAREA
- +37 ;get all removes for this patient *83
- DO GETREMOV^PSBO1(PSBXDFN)
- +38 SET PSBX2X=1
- +39 SET PSBLIST2("ACTIVE")=0
- SET PSBLIST2("FUTURE")=0
- SET PSBLIST2(EXPIREHDG)=0
- SET PSBLIST2(" * ERROR * ")=0
- +40 FOR
- SET PSBX2X=$ORDER(PSBDATA(PSBX2X))
- if +PSBX2X=0
- QUIT
- Begin DoDot:2
- +41 SET PSBDATA=PSBDATA(PSBX2X)
- +42 IF $PIECE(PSBDATA,U)="ORD"
- Begin DoDot:3
- +43 KILL PSBDRUGN
- +44 SET PSBORDN=$PIECE(PSBDATA,U,3)
- +45 ;*70
- SET PSBCLIN(PSBORDN)=$SELECT($PIECE(PSBDATA,U,32)]"":"Location: ",1:"")_$PIECE(PSBDATA,U,32)
- +46 SET PSBTB=$PIECE(PSBDATA,U,29)
- SET PSBTB=$SELECT(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
- +47 SET PSBTB(PSBORDN,PSBTB)=""
- +48 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 * ")
- +49 SET PSBSTS(PSBORDN,PSBSTS)=""
- +50 ;*70
- SET STRTDT=$PIECE(PSBDATA,U,22)
- SET STOPDT=$PIECE(PSBDATA,U,27)
- +51 ;*70
- SET PSBSTSX=$SELECT(STOPDT'>PSBNOWX:EXPIREHDG,$$FMADD^XLFDT(STRTDT,,,-PSBB4)'>PSBNOWX:"ACTIVE",STRTDT>$$FMADD^XLFDT(PSBNOWX,,,PSBB4):"FUTURE",1:" * ERROR * ")
- +52 ;
- +53 SET PSBLIST2(PSBSTSX,$PIECE(PSBDATA,U,9),PSBORDN)=""
- SET PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
- +54 if PSBOCRIT[$EXTRACT(PSBSTSX,1)
- SET PSBTOT=PSBTOT+1
- +55 SET PSBSCHTY=$PIECE(PSBDATA,U,6)
- +56 IF PSBTB="IV"
- SET PSBSCHTY=" "
- +57 SET PSBSCHTY(PSBORDN,PSBSCHTY)=""
- +58 SET PSBDOSR=$PIECE(PSBDATA,U,10)_", "_$PIECE(PSBDATA,U,11)
- +59 SET PSBDOSR=$TRANSLATE($EXTRACT(PSBDOSR,1)," ")_$EXTRACT(PSBDOSR,2,999)
- +60 SET PSBDOSR(PSBORDN,PSBDOSR)=""
- KILL PSBOMDR(PSBORDN)
- +61 SET PSBSCHD=$PIECE(PSBDATA,U,7)
- IF PSBSCHD=""
- SET PSBSCHD=" "
- +62 SET PSBSCHD(PSBORDN,PSBSCHD)=""
- +63 SET PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
- +64 ;init *83
- SET PSBNXTX2=""
- +65 IF PSBSTS["Hold"
- SET PSBNXTX2="Provider Hold"
- +66 ;
- +67 ;Next admin date triggers data for Next Action col, and also *83
- +68 ; if a remove action is pending use that text for NA col. *83
- +69 SET REMOV=$ORDER(^TMP("PSB",$JOB,"RM","B",PSBORDN,0))
- +70 IF PSBSTS'["Hold"
- IF ((PSBNXTX1)!(REMOV))
- Begin DoDot:4
- +71 ;build Admin Next Action text
- +72 if PSBNXTX1
- Begin DoDot:5
- +73 SET NXTADM=$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT)
- +74 SET PSBNXTX2=$SELECT(PSBNOWX>NXTADM:"MISSED ",1:"DUE ")_PSBNXTX1
- End DoDot:5
- +75 ;Removal tests and Next Action text build *83
- +76 SET REMOV=$ORDER(^TMP("PSB",$JOB,"RM","B",PSBORDN,0))
- +77 if REMOV
- Begin DoDot:5
- +78 SET MRR=$PIECE(PSBDATA(PSBX2X),U,35)
- +79 SET RMVTIM=$PIECE(^TMP("PSB",$JOB,"RM",REMOV),U)
- +80 ;Sched types below have no admin nor removal times, but do know
- +81 ; this MRR was given and next is Removal
- +82 IF ("^P^OC^"[("^"_PSBSCHTY_"^"))
- if PSBSTS'["Hold"
- SET PSBNXTX2="(Removal)"
- QUIT
- +83 ;sys err tst, sched rmv dt/tm empty, if null use nxt adm for rmv
- +84 IF MRR=1
- IF 'RMVTIM
- SET RMVTIM=PSBNXTX1
- +85 ;missed rm
- IF PSBNOWX>$$FMADD^XLFDT(RMVTIM,,,PSBAFT)
- Begin DoDot:6
- +86 SET PSBNXTX2="MISSED "_RMVTIM_" (Removal)"
- +87 ;err, rmv empty
- if 'RMVTIM
- SET PSBNXTX2="REMOVE"
- End DoDot:6
- +88 ;due rm
- IF '$TEST
- Begin DoDot:6
- +89 SET PSBNXTX2="REMOVE "_RMVTIM
- End DoDot:6
- +90 KILL MRR,NXTADM,RMVTIM
- End DoDot:5
- End DoDot:4
- +91 ;
- +92 SET PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
- +93 ;don't do if Expired Next action is a Removal *83
- +94 IF PSBNXTX2'["Removal"
- IF PSBNXTX2'["REMOVE"
- Begin DoDot:4
- +95 IF ("^P^OC^O"[("^"_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired")
- if PSBSTS'["Hold"
- SET PSBNXTX2=" "
- End DoDot:4
- +96 ; *139
- if PSBNXTX2=""
- SET PSBNXTX2=" "
- +97 SET PSBNXTX(PSBORDN,PSBNXTX2)=""
- +98 ; ** SPECIAL INSTRUCTIONS **
- +99 SET PSBX2X=PSBX2X+1
- +100 ; *68
- +101 KILL ^TMP("PSJBCMA5",$JOB)
- +102 IF PSBSIFLG
- DO GETSIOPI^PSJBCMA5(PSBX1X,PSBORDN,1)
- +103 FOR QQ=0:0
- SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,PSBX1X,PSBORDN,QQ))
- if 'QQ
- QUIT
- Begin DoDot:4
- +104 SET PSBSI(PSBORDN,QQ)=^TMP("PSJBCMA5",$JOB,PSBX1X,PSBORDN,QQ)
- End DoDot:4
- +105 ; *68 end
- +106 SET PSBOSTDT=$PIECE(PSBDATA,U,22)
- +107 SET PSBOSTDT(PSBORDN,PSBOSTDT)=""
- +108 SET PSBOSPDT=$PIECE(PSBDATA,U,27)
- +109 SET PSBOSPDT(PSBORDN,PSBOSPDT)=""
- End DoDot:3
- QUIT
- +110 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA(PSBX2X),U))
- Begin DoDot:3
- +111 FOR I=PSBX2X:1
- SET PSBDATA1=PSBDATA(I)
- Begin DoDot:4
- +112 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA1,U))
- SET PSBX2X=I
- SET PSBDRUGN=$GET(PSBDRUGN,"")_$PIECE(PSBDATA1,U,3)_", "
- QUIT
- +113 SET $EXTRACT(PSBDRUGN,$LENGTH(PSBDRUGN)-1)=""
- SET PSBDRUGN(PSBORDN,$EXTRACT(PSBDRUGN,1,250))=PSBDRUGN
- +114 SET PSBOMDR(PSBORDN,$EXTRACT((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
- End DoDot:4
- if $DATA(PSBOMDR(PSBORDN))
- QUIT
- End DoDot:3
- QUIT
- +115 IF $PIECE(PSBDATA,U)="END"
- QUIT
- +116 IF $PIECE(PSBDATA(PSBX2X),U)="ORF"
- Begin DoDot:3
- +117 SET PSBDATA=PSBDATA(PSBX2X)
- +118 if $PIECE(PSBDATA,U,2)]""
- SET PSBFLGD(PSBORDN,$PIECE(PSBDATA,U,3)_" - "_$PIECE(PSBDATA,U,4))=""
- End DoDot:3
- QUIT
- +119 IF ($PIECE(PSBDATA,U)="ADM")&($PIECE(PSBDATA,U,4)]"")
- Begin DoDot:3
- +120 SET PSBXID=$PIECE(PSBDATA,U,6)_U_$PIECE(PSBDATA,U,4)
- SET PSBADM(PSBORDN,(-1*($PIECE(PSBDATA,U,6))),PSBXID)=PSBDATA
- +121 SET PSBTEST=""
- FOR
- SET PSBTEST=$ORDER(PSBFLGD(PSBORDN,PSBTEST))
- if PSBTEST=""
- QUIT
- IF $PIECE(PSBTEST,":")="NOX"
- KILL PSBFLGD(PSBORDN,PSBTEST)
- QUIT
- +122 IF $ORDER(PSBSCHTY(PSBORDN,""))="P"
- SET PSBPRNR(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,9)
- +123 IF $PIECE(PSBDATA,U,3)]""
- SET PSBBID(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,3)
- +124 if PSBXFLG
- SET PSBLGD(PSBORDN,"X","INITIALS",$PIECE(PSBDATA,U,8))=""
- +125 KILL PSBDATA(PSBX2X)
- +126 IF ($PIECE(PSBDATA(PSBX2X+1),U)="CMT")
- FOR
- SET PSBDATA=PSBDATA(PSBX2X+1)
- if ($PIECE(PSBDATA,U)'="CMT")
- QUIT
- Begin DoDot:4
- +127 SET PSBX2X=PSBX2X+1
- +128 SET PSBDATA=PSBDATA(PSBX2X)
- +129 KILL PSBDATA(PSBX2X)
- +130 if $PIECE(PSBDATA,U,3)]""
- SET PSBPRNEF(PSBORDN,$PIECE(PSBXID,U,2))=$PIECE(PSBDATA,U,3)
- +131 IF 'PSBCFLG
- SET PSBDATA=PSBDATA(PSBX2X+1)
- QUIT
- +132 IF $PIECE(PSBDATA,U,2)'=""
- Begin DoDot:5
- +133 SET PSBLGD(PSBORDN,"C","INITIALS",$PIECE(PSBDATA,U,4))=""
- +134 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
- +135 IF +PSBTOT=0
- KILL PSBLIST,^XTMP("PSBO",$JOB,"PSBLIST")
- +136 DO CREATHDR^PSBOCM1
- +137 DO SUBHDR^PSBOCE
- +138 DO BLDRPT
- +139 DO WRTRPT^PSBOCM1
- +140 ;*68
- KILL ^TMP("PSJBCMA5",$JOB)
- +141 QUIT
- BLDRPT ; Build REPORT DATA
- +1 SET PSBTOPHD=PSBLNTOT-2
- +2 KILL PSBL2ULN
- +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",EXPIREHDG," * 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(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 ;*68
- KILL PSBSIDAT
- MERGE PSBSIDAT=PSBSI(PSBX2X)
- +26 SET PSBTOT1=PSBTOT1+1
- +27 KILL PSBDATA(2),PSBDATA(3),PSBSILN
- +28 DO BUILDLN^PSBOCM1
- DO SIOPI(.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,X
- 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 ;*70 build write clinic stmt
- +32 SET PSBOUTP($$PGTOT,PSBLNTOT)="W """_$GET(PSBCLIN(PSBX2X))_""""_",!"
- +33 SET PSBCNT=PSBTOT1_" "_$GET(PSB1,"")
- +34 SET PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
- +35 SET I=""
- FOR
- SET I=$ORDER(PSBRPLN(I))
- if +I=0
- QUIT
- Begin DoDot:3
- +36 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
- End DoDot:3
- +37 SET I=""
- FOR
- SET I=$ORDER(PSBSILN(I))
- if +I=0
- QUIT
- Begin DoDot:3
- +38 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
- End DoDot:3
- +39 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
- +40 KILL PSBRPLN,PSBDATA,PSBSILN
- End DoDot:2
- End DoDot:1
- +41 if +PSBTOT>0
- DO LGD
- +42 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
- SIOPI(PSBXSI,TAB,Y) ;create SIOPI text
- +1 ; *68 - modified this tag to handle only WP extra lines
- +2 ;[*70-1512]
- IF '$PIECE(PSBRPT(4),U)
- QUIT
- +3 if $ORDER(PSBXSI(""))=""
- QUIT
- +4 ;
- +5 NEW X,LBL,LBLLN,RMAR,TXT
- +6 IF $GET(Y)=""
- SET Y="Special Instructions: "
- +7 ; build label for SI field, then check $L to make a right margin
- +8 SET LBL=" "_Y
- +9 ;make margin of " "
- SET LBLLN=$LENGTH(LBL)
- SET RMAR=""
- SET $PIECE(RMAR," ",LBLLN+1)=""
- +10 KILL J,TXT,TXT1,TXT2
- SET J(0)=""
- +11 SET J=($ORDER(J(""),-1)+1)
- SET PSBSILN(J)=""
- SET J(J)=""
- SET J=($ORDER(J(""),-1)+1)
- +12 FOR X=0:0
- SET X=$ORDER(PSBXSI(X))
- if 'X
- QUIT
- Begin DoDot:1
- +13 ;put label & 1st line together
- IF X=1
- SET TXT=LBL_PSBXSI(X)
- +14 ;all other lines add rmar
- IF '$TEST
- SET TXT=RMAR_PSBXSI(X)
- +15 SET TXT1=TXT
- +16 IF ($LENGTH(TXT1)>0)
- IF $FIND(TXT1,"""")>1
- Begin DoDot:2
- +17 SET TXT1=$TRANSLATE(TXT1,"""","^")
- +18 IF $LENGTH(TXT1)+5'<TAB
- SET TXT2=$EXTRACT(TXT1,TAB-9,999)
- SET TXT1=$EXTRACT(TXT1,1,TAB-10)
- +19 IF $LENGTH(TXT1,"^")>1
- FOR Y=1:1:$LENGTH(TXT1,"^")-1
- SET $PIECE(TXT1,"^",Y)=$PIECE(TXT1,"^",Y)_""""
- +20 IF $DATA(TXT2)
- IF $LENGTH(TXT2,"^")>1
- FOR X=1:1:$LENGTH(TXT2,"^")-1
- SET $PIECE(TXT2,"^",X)=$PIECE(TXT2,"^",X)_""""
- +21 SET TXT1=$TRANSLATE(TXT1,"^","""")
- IF $DATA(TXT2)
- SET TXT2=$TRANSLATE(TXT2,"^","""")
- End DoDot:2
- +22 SET $EXTRACT(PSBSILN(J),5,999)=TXT1
- SET J(J)=""
- SET J=J+1
- +23 IF $DATA(TXT2)
- SET $EXTRACT(PSBSILN(J),5,999)=TXT2
- SET J(J)=""
- SET J=J+1
- End DoDot:1
- +24 SET $EXTRACT(PSBSILN(J),3,999)=" "
- SET J(J)=""
- SET J=J+1
- +25 QUIT
- LGD ; Create Report's Legend
- +1 KILL PSBLGDO
- +2 SET PSBLGD("ORDER TYPES","C")="Continuous"
- +3 SET PSBLGD("ORDER TYPES","O")="One Time"
- +4 SET PSBLGD("ORDER TYPES","OC")="On Call"
- +5 SET PSBLGD("ORDER TYPES","P")="PRN"
- +6 SET PSB=0
- FOR
- SET PSB=$ORDER(PSBLGD("INITIALS",PSB))
- if +PSB=0
- QUIT
- Begin DoDot:1
- +7 SET PSBINIT=$$GET1^DIQ(200,PSB_",","INITIAL")
- SET PSBLGD("INITIALS",$SELECT(PSBINIT']" ":"*n/a*",1:PSBINIT))=$$GET1^DIQ(200,PSB_",","NAME")
- +8 KILL PSBLGD("INITIALS",PSB)
- End DoDot:1
- +9 SET PSBPGNUM=$ORDER(PSBOUTP(""),-1)
- SET PSBLGDO(0)="REPORT LEGEND"
- +10 SET PSBLGDO(1)=""
- +11 SET PSBLGDO(2)=$SELECT($GET(PSBNO,0):"",1:"SCHEDULE TYPES")
- +12 SET PSBLGDO(3)=""
- +13 IF '$GET(PSBNO,0)
- SET X1=""
- SET X2=3
- FOR
- SET X1=$ORDER(PSBLGD("ORDER TYPES",X1))
- if X1=""
- QUIT
- SET X2=X2+1
- SET PSBLGDO(X2)=X1
- SET $EXTRACT(PSBLGDO(X2),5)="- "_PSBLGD("ORDER TYPES",X1)
- +14 IF $DATA(PSBLGD("INITIALS"))
- SET $EXTRACT(PSBLGDO(2),35)="INITIALS"
- SET X1=""
- SET X2=3
- FOR
- SET X1=$ORDER(PSBLGD("INITIALS",X1))
- if X1=""
- QUIT
- SET X2=X2+1
- SET $EXTRACT(PSBLGDO(X2),35)=X1
- SET $EXTRACT(PSBLGDO(X2),40)="- "_PSBLGD("INITIALS",X1)
- +15 SET (PSBMORE,X0)=10+($ORDER(PSBLGDO(""),-1))
- +16 IF (PSBLNTOT+PSBMORE)'<IOSL
- SET PSBLNTOT=PSBTOPHD-2
- SET PSBPGNUM=PSBPGNUM+1
- +17 IF IOSL<1000
- SET X2=PSBLNTOT
- FOR
- if X2'<(IOSL-(X0+3))
- QUIT
- SET PSBOUTP($$PGTOT,PSBLNTOT)="W !"
- SET X2=X2+1
- +18 SET PSBMORE=X0
- +19 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TRANSLATE($JUSTIFY("",IOM)," ","=")_""",!"
- +20 FOR X1=0:1
- if '$DATA(PSBLGDO(X1))
- QUIT
- SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_$GET(PSBLGDO(X1)," ")_""""
- +21 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TRANSLATE($JUSTIFY("",IOM)," ","=")_""",!"
- +22 QUIT