Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBOIV

PSBOIV.m

Go to the documentation of this file. 
  1. PSBOIV ;BIRMINGHAM/TEJ-IV BAG STATUS REPORT ;Mar 2004
  1.  ;;3.0;BAR CODE MED ADMIN;**32**;Mar 2004;Build 32
  1.  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1.  ;
  1.  ; Reference/IA
  1.  ; File 52.6/436
  1.  ; File 52.7/437
  1.  ; File 4/10090
  1.  ; File 2/10035 
  1. EN ; Entry
  1.  N PSB1,PSBFUTR
  1.  K PSBSRTBY,PSBOCRIT,PSBACRIT,NO S PSBCFLG=0
  1.  S PSBFUTR=$TR(PSBRPT(1),"~","^")
  1.  I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
  1.  S PSBDTST=+$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)
  1.  S PSBDTSP=+$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
  1.  S PSBOCRIT=""        ;  Ord Sttus "A"ctive, "D"C ed, "E"xprd"
  1.  S:$P(PSBFUTR,U,5) PSBOCRIT=PSBOCRIT_"A"
  1.  S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_"D"
  1.  S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_"E"
  1.  S PSBACRIT=""        ;  Actn Sttus "C"ompl, "I"nfusi, "M"issng, "S"tpped, "H"ld, "R"efsd", "N"o Actn
  1.  S:$P(PSBFUTR,U,12) PSBACRIT=PSBACRIT_"I"
  1.  S:$P(PSBFUTR,U,13) PSBACRIT=PSBACRIT_"S"
  1.  S:$P(PSBFUTR,U,14) PSBACRIT=PSBACRIT_"C"
  1.  S:$P(PSBFUTR,U,15) PSBACRIT=PSBACRIT_"N"
  1.  S:$P(PSBFUTR,U,16) PSBACRIT=PSBACRIT_"M"
  1.  S:$P(PSBFUTR,U,17) PSBACRIT=PSBACRIT_"H"
  1.  S:$P(PSBFUTR,U,18) PSBACRIT=PSBACRIT_"R"
  1.  D NOW^%DTC S (Y,PSBXNOW)=% D DD^%DT S:PSBDTSP=0 PSBDTSP=Y S PSBDTTM=Y
  1.  I +PSBDTST=0 S PSBDTST=X S PSBDTST=$$FMADD^XLFDT(PSBDTST,-3)_".0000"
  1.  S (PSBPGNUM,PSBLNTOT,PSBTOT,PSB1)=""
  1.  K PSBLIST,PSBLIST2,PSBBGS,PSBNOX
  1.  S PSBXDFN=$P(PSBRPT(.1),U,2)
  1.  S PSBLIST(PSBXDFN)=""
  1.  S PSB1=$O(PSBLIST("")) I +PSB1'=0  K ^TMP("PSJ",$J) D EN^PSJBCMA(PSB1,PSBDTST,PSBDTST)
  1.  I ^TMP("PSJ",$J,1,0)'=-1 D
  1.  .S PINX=0 F  S PINX=$O(^TMP("PSJ",$J,PINX)) Q:+PINX'>0  D
  1.  ..S PSB2=$P(^TMP("PSJ",$J,PINX,0),U,3)
  1.  ..I PSB2["V" D  Q
  1.  ...; flter critri
  1.  ...D CLEAN^PSBVT,PSJ1^PSBVT(PSB1,PSB2)
  1.  ...Q:$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,$G(PSBIVPSH,0))
  1.  ...Q:PSBOST>PSBDTSP
  1.  ...I "DE"'[PSBOSTS I PSBOSP'>PSBXNOW S PSBOSTS="E"
  1.  ...Q:PSBOCRIT'[PSBOSTS  ;incl ord stat crit
  1.  ...Q:(PSBOSP<PSBXNOW)&(PSBOCRIT'["E")&(PSBOSTS'="D")
  1.  ...S PSBLIST2(PSB2,"OStart")=PSBOST
  1.  ...S PSBLIST2(PSB2,"OStop")=PSBOSP
  1.  ...S PSBLIST2(PSB2,"OStatus")=$S((PSBOSTS="D"):"Discontinued",(PSBOSTS="DE"):"Discontinued (Edit)",PSBXNOW>PSBOSP:"Expired",PSBOSTS="A":"Active",PSBOSTS="H":"On Hold",1:PSBOSTS)
  1.  ...S PSBLIST2(PSB2,"OPI")=PSBOTXT
  1.  ...M PSBLIST2(PSB2,"ADD")=PSBADA
  1.  ...M PSBLIST2(PSB2,"SOL")=PSBSOLA
  1.  ...D EN^PSBPOIV(PSB1,PSB2)
  1.  ...I +$O(^TMP("PSBAR",$J,""))>0 S X="" F  S X=$O(^TMP("PSBAR",$J,X)) Q:+X=0  S PSBBGS(PSB2,X)=$P(^TMP("PSBAR",$J,X),U,2)
  1.  ...D:PSBACRIT["N"
  1.  ....S NO=1
  1.  ....I $D(PSBBGS(PSB2))  S X="" F  S X=$O(PSBBGS(PSB2,X)) Q:+X=0  I PSBBGS(PSB2,X)'="" S NO=0 Q
  1.  ....I $D(^PSB(53.79,"AORDX",PSB1,PSB2)) S NO=0 Q
  1.  ...I $G(NO,0) I PSBOSTS="A" S PSBNOX(PSB2)="",PSBTOT=PSBTOT+1 Q
  1.  ...I $D(^PSB(53.79,"AUID",PSB1,PSB2)) M PSBBGS(PSB2)=^PSB(53.79,"AUID",PSB1,PSB2)
  1.  ...; Get X - "ASSOC BAGS"
  1.  ...S X="" F  S X=$O(PSBBGS(PSB2,X)) Q:+X=0  I $G(PSBBGS(PSB2,X),"")'=""  D
  1.  ....S Y="" F  S Y=$O(^PSB(53.79,"AUID",PSB1,Y)) Q:Y=""  D  Q:Y="DONE"
  1.  .....I $D(^PSB(53.79,"AUID",PSB1,Y,X)) S PSBBGS(PSB2,X,$O(^PSB(53.79,"AUID",PSB1,Y,X,"")))="" S Y="DONE"
  1.  ...S X="" F  S X=$O(PSBBGS(PSB2,X)) Q:+X=0  I $O(PSBBGS(PSB2,X,""))="" K PSBBGS(PSB2,X)
  1.  ...S PSB3="" F  S PSB3=$O(PSBBGS(PSB2,PSB3)) Q:PSB3=""  D
  1.  ....S PSB4="" F  S PSB4=$O(PSBBGS(PSB2,PSB3,PSB4)) Q:+PSB4=0  D
  1.  .....I ($$GET1^DIQ(53.79,PSB4_",",.06,"I")'>PSBDTST)!($$GET1^DIQ(53.79,PSB4_",",.06,"I")'<PSBDTSP) K PSBBGS(PSB2,PSB3) Q
  1.  .....I PSBACRIT'[$$GET1^DIQ(53.79,PSB4_",",.09,"I") K PSBBGS(PSB2,PSB3) Q
  1.  .....S PSBBSTS(PSB2,PSB3,$$GET1^DIQ(53.79,PSB4_",",.09))=$$GET1^DIQ(53.79,PSB4_",",.06,"I"),PSBTOT=PSBTOT+1
  1.  .....I "SI"[$$GET1^DIQ(53.79,PSB4_",",.09,"I") I PSBXNOW>$$FMADD^XLFDT($$GET1^DIQ(53.79,PSB4_",",.06,"I"),,24) S PSB24HR(PSB2,PSB3)=""
  1.  .....I PSBCFLG S PSB5=0 F  S PSB5=$O(^PSB(53.79,PSB4,.3,PSB5)) Q:+PSB5=0  D
  1.  ......I $P(^PSB(53.79,PSB4,.3,PSB5,0),U,3)=$$GET1^DIQ(53.79,PSB4_",",.06,"I") S PSBCMNT(PSB2,PSB3)="Comment: "_$P(^PSB(53.79,PSB4,.3,PSB5,0),U)
  1.  S INX="" F  S INX=$O(PSBLIST2(INX)) Q:INX=""  I '$D(PSBBGS(INX))&'$D(PSBNOX(INX)) K PSBLIST2(INX)
  1.  I +PSBTOT=0 K PSBLIST
  1.  S Y=PSBDTST D DD^%DT S Y1=Y S Y=PSBDTSP D DD^%DT S Y2=Y
  1.  D CREATHDR
  1.  D SUBHDR^PSBOIV1
  1.  D BLDRPT
  1.  D WRTRPT
  1.  K PSBSILN,PSBOUTP,PSBLIST2,PSBCMNT,PSBNOX
  1.  Q
  1. BLDRPT ; Buld Reprt
  1.  S (PSB2,PSB3,PSB4)=""
  1.  S PSBTOPHD=PSBLNTOT
  1.  I '$D(PSBLIST2) D  Q
  1.  .S PSBOUTP(0,14)="W !!,""<<<< NO DATA TO DISPLAY >>>>"",!!"
  1.  S PSBTOT1=0
  1.  K PSBDATA
  1.  K J S J=1
  1.  F  S PSB2=$O(PSBLIST2(PSB2)) Q:+PSB2=0  D
  1.  .S PSBORDX="" S PSBORDX=PSB2
  1.  .S PSBDATA(1)=$$FMTDT^PSBOIV1($E(PSBLIST2(PSB2,"OStart"),1,12))
  1.  .S PSBDATA(2)=$$FMTDT^PSBOIV1($E(PSBLIST2(PSB2,"OStop"),1,12))
  1.  .S PSBDATA(3)=PSBLIST2(PSB2,"OStatus")
  1.  .M PSBDATA(4,"ADD")=PSBLIST2(PSB2,"ADD") I $D(PSBDATA(4,"ADD",1)) S PSBDATA(4)="MED"
  1.  .M PSBDATA(4,"SOL")=PSBLIST2(PSB2,"SOL") I $D(PSBDATA(4,"SOL",1)) S PSBDATA(4)="MED"
  1.  .; Bag(s)
  1.  .I $D(PSBNOX(PSB2)) S PSBFLGD(PSB2," * No Action Taken On Order * ")=""
  1.  .I '$D(PSBNOX(PSB2))!(PSBACRIT["N")  F  S PSB3=$O(PSBBGS(PSB2,PSB3)) Q:+PSB3=0  D
  1.  ..S PSBDATA(5,PSB3)=PSB3
  1.  ..S PSBDATA(6,PSB3)=$O(PSBBSTS(PSB2,PSB3,""))
  1.  ..I $D(PSB24HR(PSB2,PSB3)) S PSBDATA(7,PSB3)=">24h"
  1.  ..I '$D(PSBNOX(PSB2)) S PSBDATA(8,PSB3)=$$FMTDT^PSBOIV1($E(PSBBSTS(PSB2,PSB3,PSBDATA(6,PSB3)),1,12))
  1.  ..E  S PSBDATA(8,PSB3)="No Action On Order"
  1.  .K PSBOPDAT S PSBOPDAT(1)=$G(PSBLIST2(PSB2,"OPI"),"")
  1.  .S PSBTOT1=PSBTOT1+1
  1.  .K PSBRPLN,PSBSILN
  1.  .D BUILDLN,SIOPI^PSBOCM(.PSBOPDAT,PSBTAB8,"Other Print Info:")
  1.  .I $D(PSBRPLN) S PSBMORE=$O(PSBRPLN(""),-1)+4 I $D(PSBSILN) S PSBMORE=PSBMORE+$O(PSBSILN(""),-1)
  1.  .S (PSB1,PSB)="" I $D(PSBFLGD(PSB2)) F  S PSB=$O(PSBFLGD(PSB2,PSB)) Q:PSB=""  I ($P(PSB,":")'="STAT") S PSB1=$G(PSB1,"")_PSB
  1.  .S PSBCNT=PSBTOT1_"  ("_PSB2_") "_PSB1,$E(PSBCNT,IOM)="|"
  1.  .S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBCNT_""""
  1.  .F N=$O(PSBRPLN("")):1:$O(PSBRPLN(""),-1)  D
  1.  ..S PSB1X=0 S PSB1X=(($L(PSBRPLN(N),"""")-1)\2) I ($E(PSBRPLN(N),(PSBTAB8)+PSB1X)']" ") S $E(PSBRPLN(N),(PSBTAB8)+PSB1X)="|"
  1.  ..S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(N)_""""
  1.  .K PSBRPLN,PSBDATA
  1.  .S I="" F  S I=$O(PSBSILN(I)) Q:+I=0  D
  1.  ..S PSB1X=0 S PSB1X=(($L(PSBSILN(I),"""")-1)\2)
  1.  ..I ($E(PSBSILN(I),(PSBTAB8)+PSB1X)']" ") S $E(PSBSILN(I),(PSBTAB8)+PSB1X)="|"
  1.  ..S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
  1.  .S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
  1.  Q
  1. BUILDLN ; Constr recs
  1.  K J,LN S J(0)="" F PSBFLD=1:1:3 I $G(PSBDATA(PSBFLD))]"" S J=1 D FORMDAT^PSBOIV1(PSBFLD) S J=1
  1.  F X=1:1 Q:'$D(PSBDATA(4,"ADD",X))  D
  1.  .S PSBDATA(4)=$P(PSBDATA(4,"ADD",X),U,3)
  1.  .D FORMDAT^PSBOIV1(4)
  1.  .S J=$O(J(""),-1)+1
  1.  F X=1:1 Q:'$D(PSBDATA(4,"SOL",X))  D
  1.  .S PSBDATA(4)=$P(PSBDATA(4,"SOL",X),U,3)
  1.  .D FORMDAT^PSBOIV1(4)
  1.  .S J=$O(J(""),-1)+1
  1.  F PSBFLD=5:1:8 I $D(PSBDATA(PSBFLD)) K J S J=1 D
  1.  .S X="" F  S X=$O(PSBDATA(PSBFLD,X)) Q:+X=0  D
  1.  ..S PSBDATA(PSBFLD)=PSBDATA(PSBFLD,X)
  1.  ..I PSBFLD=5 S LN(X,J)=""
  1.  ..D:PSBFLD'=8 FORMDAT^PSBOIV1(PSBFLD)
  1.  ..S J=$O(J(""),-1)+1
  1.  ..I (PSBCFLG&(PSBFLD=5)),($D(PSBCMNT(PSB2,X))) D WRAPPER^PSBOIV1(PSBTAB4+1,(PSBTAB8-PSBTAB4)-1,PSBCMNT(PSB2,X)),WRAPPER^PSBOIV1(PSBTAB4+1,PSBTAB8-PSBTAB4," ")
  1.  .I PSBFLD=5 F J=1:1:$O(J(""),-1) S PREVLN(J)=$G(PSBRPLN(J),"")
  1.  .I PSBFLD'=5 I $D(PREVLN) S X="" F  S X=$O(LN(X)) Q:X=""  S J=$O(LN(X,"")) D:$D(PSBDATA(PSBFLD,X))
  1.  ..S $E(PREVLN(J),@("PSBTAB"_(PSBFLD-1))+1,@("PSBTAB"_(PSBFLD)))=PSBDATA(PSBFLD,X)
  1.  I $D(PREVLN) F J=1:1:$O(PREVLN(""),-1) S PSBRPLN(J)=PREVLN(J)
  1.  K PREVLN,LN
  1.  Q
  1. WRTRPT ;
  1.  I $O(PSBOUTP(""),-1)<1 D  Q
  1.  .X PSBOUTP($O(PSBOUTP(""),-1),14)
  1.  .D FTR
  1.  S PSBPGNUM=1
  1.  S PSBZ="" F  S PSBZ=$O(PSBOUTP(PSBZ)) Q:PSBZ=""  D
  1.  .I PSBPGNUM'=PSBZ D FTR S PSBPGNUM=PSBZ D HDR,SUBHDR^PSBOIV1
  1.  .S PSB2="" F  S PSB2=$O(PSBOUTP(PSBZ,PSB2)) Q:PSB2=""  D
  1.  ..X PSBOUTP(PSBZ,PSB2)
  1.  D FTR
  1.  Q
  1. HDR ;
  1.  W:$Y>1 @IOF
  1.  W:$X>1 !
  1.  S PSBRPNM="BCMA IV BAG STATUS REPORT"
  1.  S LN=0
  1.  D:$P(PSBRPT(.1),U,1)="P"
  1.  .S LN=LN+1,PSBHDR(LN)=PSBRPNM_" for "_$$FMTE^XLFDT($P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7))_" to "_$$FMTE^XLFDT($P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9))
  1.  .S LN=LN+1,PSBHDR(LN)="Order Status(es): --"
  1.  .F Y=5,7,8 I $P(PSBFUTR,U,Y) S $P(PSBHDR(LN),": ",2)=$P(PSBHDR(LN),": ",2)_$S(PSBHDR(2)["--":"",1:"/ ")_$P("^^^^Active^^DC'd^Expired^^^^^^^^^^",U,Y)_" " S PSBHDR(LN)=$TR(PSBHDR(LN),"-","")
  1.  .S LN=LN+1,PSBHDR(LN)="Bag Status(es): --"
  1.  .F Y=12:1:18 I $P(PSBFUTR,U,Y) S $P(PSBHDR(LN),": ",2)=$P(PSBHDR(LN),": ",2)_$S(PSBHDR(LN)["--":"",1:"/ ")_$P("^^^^^^^^^^^Infusing^Stopped^Completed^No Action Taken^Missing Dose^Held^Refused",U,Y)_" " S PSBHDR(LN)=$TR(PSBHDR(LN),"-","")
  1.  .I PSBCFLG S LN=LN+1,PSBHDR(LN)="Include Comments/Reasons"
  1.  .D PT^PSBOHDR(PSBXDFN,.PSBHDR) W !
  1.  Q
  1. FTR ;
  1.  I (IOSL<100) F  Q:$Y>(IOSL-5)  W !,?(IOM-1),"|"
  1.  S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
  1.  S PSBPGRM=PSBTAB8-($L(PSBPG))
  1.  D PTFTR^PSBOHDR()
  1.  W !,PSBRPNM,"     ",?(PSBPGRM-($L(PSBDTTM)+3)),PSBDTTM_"  "_PSBPG
  1.  Q
  1. PGTOT(X) ;mnt PAGE Number
  1.  I (PSBLNTOT+PSBMORE)>(IOSL) S PSBPGNUM=PSBPGNUM+1,PSBLNTOT=PSBTOPHD S PSBMORE=$S(PSBMORE>(IOSL-(PSBTOPHD)):(IOSL-(PSBTOPHD)),1:PSBMORE)
  1.  I $G(X,1) S PSBLNTOT=PSBLNTOT+$G(X,1),PSBMORE=PSBMORE-$G(X,1)
  1.  Q PSBPGNUM
  1. CREATHDR ;
  1.  K PSBHD1,PSBHD2
  1.  I IOM'<132 S PSBMORE=4,PSBHD1=$P($T(HD132A),";",2),PSBHD2=$P($T(HD132B),";",2),PSBBLANK=$P($T(H132BLK),";",2)
  1.  E  S PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY" K PSBLIST2 Q
  1.  ; reset tabs
  1.  S PSBTAB0=1 F PSBI=0:1:($L(PSBHD1,"|")-1) S:PSBI>0 @("PSBTAB"_PSBI)=($F(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
  1.  S PSBPGNUM=1
  1.  D HDR
  1.  Q
  1. HD132A ;     Order       |       Order       |    Order     |     Medication      |      Bag UID      |    Bag    |     | Action Date/Time |
  1.  Q
  1. HD132B ;   Start Date    |      Stop Date    |    Status    |                     |                   |   Status  |     |                  |
  1.  Q
  1. H132BLK ;;
  1.  Q