- PSBCHKIV ;BIRMINGHAM/TEJ-BCMA CHECK IV ROUTINE ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**16**;Mar 2004
- ;
- ;This routine will provide "change" details for infus or stopped IV bags.
- ;
- ; Reference/IA
- ; EN^PSJBCMA1/2829
- ; EN^PSJBCMA2/2830
- ;
- RPC(RESULTS,DFN,ORDIV) ;
- I '$D(ORDIV) S RESULTS(0)=0 Q
- N PSBGNODE,PSBPIN,PSBXX,PSBX,PSBBUIDS,PSBBUID K PSBBAGD,PSBADDS,PSBSOLS,RESULTS
- D NOW^%DTC S X1=X,X2=-3 D C^%DTC S PSBDT=X
- S PSBPIN=DFN
- S Z="" F S Z=$O(ORDIV(Z)) Q:Z="" D
- .D GETORD^PSBCHIVH(ORDIV(Z))
- .F S=1:1 Q:$P(PSBONXSB,"^",S)="" D
- ..S PSBORD=$P(PSBONXSB,"^",S)
- ..S PSBGNODE="^PSB(53.79,"_"""AUID"""_","_DFN_")"
- ..F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE="" Q:$QS(PSBGNODE,3)'=DFN D
- ...I $QS(PSBGNODE,4)=PSBORD D
- ....S PSBBIEN=$QS(PSBGNODE,6)
- ....S PSBSTATS=$P(^PSB(53.79,PSBBIEN,0),U,9) D:(PSBSTATS="I")!(PSBSTATS="S") Q
- .....S PSBBUID=$QS(PSBGNODE,5),PSBOR=$$FNDLBLO^PSBVDLU2(PSBPIN,$QS(PSBGNODE,4),PSBBUID),(PSBXOR,PSBLOR)=PSBOR
- .....; G IV bag
- .....; IS ORD is "live"
- .....S PSBNXOR=PSBOR
- .....S PSBSTOP=0 F K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBNXOR,1) S:($P(^TMP("PSJ1",$J,0),U,5)']"")&($P($G(^TMP("PSJ1",$J,4)),U,7)<PSBDT) PSBSTOP=1 Q:PSBNXOR=$P(^TMP("PSJ1",$J,0),U,5) S PSBNXOR=$P(^TMP("PSJ1",$J,0),U,5) Q:PSBNXOR']""
- .....I 'PSBSTOP F PSBXX=1:1 D K ^TMP("PSJ1",$J) S:PSBOR="" PSBCO(PSBXOR)=PSBLOR Q:PSBOR="" ;
- ......K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBOR,1)
- ......S PSBDX="" F S PSBDX=$O(^TMP("PSJ1",$J,PSBDX)) Q:PSBDX="" I $D(^TMP("PSJ1",$J,PSBDX,1000,PSBBUID)) S PSBLABDT=$P(^TMP("PSJ1",$J,PSBDX,1000,PSBBUID,0),U) Q
- ......K ^TMP("PSJ2",$J) D EN^PSJBCMA2(DFN,PSBOR,1) D:$D(^TMP("PSJ2",$J))
- .......S PSBX=0 F S PSBX=$O(^TMP("PSJ2",$J,PSBX)) Q:PSBX="" D:$P(^TMP("PSJ2",$J,PSBX,1),U,3)]""
- ........S PSBCHGDT=$P(^TMP("PSJ2",$J,PSBX,1),U),PSBPARAM=$P(^TMP("PSJ2",$J,PSBX,1),U,3)
- ........I ($P(^TMP("PSJ2",$J,PSBX,1),U)'<$G(PSBLABDT)) S PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)=" changed to ",PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)=PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)_$$NEWDATA(PSBPARAM)
- ......M PSBBAGD(PSBXOR,PSBXX,0)=^TMP("PSJ1",$J,0),PSBBAGD(PSBXOR,PSBXX,4)=^TMP("PSJ1",$J,4),PSBBAGD(PSBXOR,PSBXX,2)=^TMP("PSJ1",$J,2)
- ......F PSBX=800,850,900,950,1000 D
- .......I "800900"[PSBX M PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$J,PSBX,PSBBUID)
- .......I ("850950"[PSBX),'$D(PSBBAGD(PSBXOR,PSBXX,(PSBX-50),PSBBUID)) M PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$J,PSBX)
- .......S:PSBXX=1 PSBBUIDS(PSBXOR,PSBBUID)=PSBXOR_U_PSBBUID_U_($P(PSBBAGD(PSBXOR,PSBXX,2),U,2))_U_PSBSTATS
- .......D:(PSBXX=1)
- ........I (PSBX=800) F PSBXY=0 S PSBXY=$O(PSBBAGD(PSBXOR,1,800,PSBBUID,PSBXY)) Q:PSBXY="" S PSBBUIDS(PSBXOR,PSBBUID,"ADD",PSBXY)="ADD"_U_PSBBAGD(PSBXOR,1,800,PSBBUID,PSBXY)
- ........I (PSBX=900) F PSBXY=0 S PSBXY=$O(PSBBAGD(PSBXOR,1,900,PSBBUID,PSBXY)) Q:PSBXY="" S PSBBUIDS(PSBXOR,PSBBUID,"SOL",PSBXY)="SOL"_U_PSBBAGD(PSBXOR,1,900,PSBBUID,PSBXY)
- ........I (PSBX=850) F PSBXY=0 S PSBXY=$O(PSBBAGD(PSBXOR,1,850,PSBBUID,PSBXY)) Q:PSBXY="" S PSBBUIDS(PSBXOR,PSBBUID,"ADD",PSBXY)="ADD"_U_PSBBAGD(PSBXOR,1,850,PSBBUID,PSBXY,0)
- ........I (PSBX=950) F PSBXY=0 S PSBXY=$O(PSBBAGD(PSBXOR,1,950,PSBBUID,PSBXY)) Q:PSBXY="" S PSBBUIDS(PSBXOR,PSBBUID,"SOL",PSBXY)="SOL"_U_PSBBAGD(PSBXOR,1,950,PSBBUID,PSBXY,0)
- ......S PSBLOR=$P(^TMP("PSJ1",$J,0),U,3),PSBOR=$P(^TMP("PSJ1",$J,0),U,5) K ^TMP("PSJ1",$J)
- ......I PSBOR["P" S PSBOR=$$PSBNXACT(PSBPIN,PSBOR)
- S (PSBLINES,RESULTS(0))=0
- Q:$G(PSBGNODE)=""
- I $D(PSBBAGD) S PSBXOR="" F S PSBXOR=$O(PSBBAGD(PSBXOR)) Q:PSBXOR="" D
- .S PSBXX=$O(PSBBAGD(PSBXOR,""),-1)
- .I $P(PSBBAGD(PSBXOR,PSBXX,4),U,7)<PSBDT S PSBLINES=0 Q ; "Whole of" order exp 3 dAYS ago proc nxt
- .F PSBXX=1:1:($O(PSBBAGD(PSBXOR,""),-1)-1) S PSBXY=PSBXX+1 D:$D(PSBBAGD(PSBXOR,PSBXY))
- ..D CLEAN^PSBVT,PSJ1^PSBVT(PSBPIN,$P(PSBBAGD(PSBXOR,PSBXX,0),U,3))
- ..K PSBOTMP
- ..I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E S PSBOTMP("ADD")=""
- ..I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E S PSBOTMP("SOL")="" ;solut,vol
- ..K PSBADA,PSBSOLA
- ..S PSBOTMP("INFUSION RATE")=$G(PSBIFR)
- ..S PSBOTMP("MED ROUTE")=$G(PSBMR)
- ..S PSBOTMP("REMARKS")=$G(PSBRMRK)
- ..S PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
- ..S PSBOTMP("PROVIDER")=PSBMD
- ..S PSBOTMP("START DATE/TIME")=PSBOST
- ..S PSBOTMP("STOP DATE/TIME")=PSBOSP
- ..D CLEAN^PSBVT,PSJ1^PSBVT(PSBPIN,$P(PSBBAGD(PSBXOR,PSBXY,0),U,3))
- ..D EN^PSJBCMA2(PSBPIN,$P(PSBBAGD(PSBXOR,PSBXY,0),U,3),1) S:$P(^TMP("PSJ2",$J,1,1),U)]"" PSBCHGDT=$P(^TMP("PSJ2",$J,1,1),U)
- ..I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD
- ..I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL
- ..I PSBIFR'=PSBOTMP("INFUSION RATE") S:PSBOTMP("INFUSION RATE")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"INFUSION RATE")=" changed to "_PSBIFR
- ..I PSBMR'=PSBOTMP("MED ROUTE") S:PSBMR'=PSBOTMP("MED ROUTE")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"MED ROUTE")=" changed to "_PSBMR
- ..I PSBRMRK'=PSBOTMP("REMARKS") S:PSBOTMP("REMARKS")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"REMARKS")=" changed to "_PSBRMRK
- ..I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") S:PSBOTMP("OTHER PRINT INFO")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"OTHER PRINT INFO")=" changed to "_PSBOTXT
- ..I PSBMD'=PSBOTMP("PROVIDER") S:PSBOTMP("PROVIDER")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"PROVIDER")=" changed to "_PSBMDX
- ..I $E(PSBOST,1,12)'=$E(PSBOTMP("START DATE/TIME"),1,12) S PSBIVCHG(PSBXOR,PSBCHGDT,"START DATE/TIME")=" changed to "_PSBOSTX
- ..I $E(PSBOSP,1,12)'=$E(PSBOTMP("STOP DATE/TIME"),1,12) S PSBIVCHG(PSBXOR,PSBCHGDT,"STOP DATE/TIME")=" changed to "_PSBOSPX
- ..D CLEAN^PSBVT
- ; Get RESULTS
- D:$D(PSBIVCHG)
- .S PSBXX="" F S PSBXX=$O(PSBIVCHG(PSBXX)) S:PSBLINES>0 PSBLINES=PSBLINES+1,RESULTS(PSBLINES)="END",RESULTS(0)=PSBLINES Q:PSBXX="" D
- ..S PSBXY="" F S PSBXY=$O(PSBBUIDS(PSBXX,PSBXY)) Q:PSBXY="" D
- ...S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY)_U_PSBCO(PSBXX)
- ...S PSBXZ=0 F S PSBXZ=$O(PSBBUIDS(PSBXX,PSBXY,"ADD",PSBXZ)) Q:PSBXZ="" S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY,"ADD",PSBXZ)
- ...S PSBXZ=0 F S PSBXZ=$O(PSBBUIDS(PSBXX,PSBXY,"SOL",PSBXZ)) Q:PSBXZ="" S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY,"SOL",PSBXZ)
- ..S PSBXY="" F S PSBXY=$O(PSBIVCHG(PSBXX,PSBXY),-1) Q:PSBXY="" D
- ...S PSBXZ="" F S PSBXZ=$O(PSBIVCHG(PSBXX,PSBXY,PSBXZ)) Q:PSBXZ="" D
- ....I '("ADDITIVE STRENGTH SOLUTION VOLUME "[PSBXZ) S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)="CD"_U_PSBXY_U_PSBXZ_PSBIVCHG(PSBXX,PSBXY,PSBXZ)
- ....I "ADDITIVE STRENGTH SOLUTION VOLUME "[PSBXZ S PSBZX="" F S PSBZX=$O(PSBIVCHG(PSBXX,PSBXY,PSBXZ,PSBZX)) Q:PSBZX="" S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)="CD"_U_PSBXY_U_PSBXZ_PSBIVCHG(PSBXX,PSBXY,PSBXZ,PSBZX)
- K PSBIVCHG,PSBLINES,PSBBAGD,PSBAD,PSBSOL
- Q
- CHKADD N X,PSBADDS ; Check addit(s)
- I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q ; no adds
- S X="" F S X=$O(PSBOTMP("ADD",X)) Q:X="" K PSBAD,PSBSTR S PSBAD=$P(PSBOTMP("ADD",X),U,2),PSBSTR=$P(PSBOTMP("ADD",X),U,4),PSBADDS(PSBAD,PSBSTR)=PSBOTMP("ADD",X)
- S X="" F S X=$O(PSBADA(X)) Q:X="" D
- .K PSBAD,PSBSTR S PSBAD=$P(PSBADA(X),U,2),PSBSTR=$P(PSBADA(X),U,4)
- .I $D(PSBADDS(PSBAD,PSBSTR)) K PSBADDS(PSBAD,PSBSTR) Q
- .I '$D(PSBADDS(PSBAD)) S PSBTXT=PSBADA(X),$P(PSBTXT,U,1)="",$P(PSBTXT,U,2)="",PSBIVCHG(PSBXOR,PSBCHGDT,"ADDITIVE",PSBAD)=" added"_$TR(PSBTXT,U," ")
- .E K PSBADDS(PSBAD) S PSBIVCHG(PSBXOR,PSBCHGDT,"STRENGTH ",PSBAD)=$P(PSBADA(X),U,3)_" changed to "_$P(PSBADA(X),U,4)
- S X="" F S X=$O(PSBADDS(X)) Q:X="" I '$D(PSBIVCHG(PSBXOR,PSBCHGDT,"ADDITIVE",X)) S PSBTXT=PSBADDS(X,($O(PSBADDS(X,"")))),$P(PSBTXT,U,1)="",$P(PSBTXT,U,2)="",PSBIVCHG(PSBXOR,PSBOST,"ADDITIVE",X)=" deleted"_$TR(PSBTXT,U," ")
- Q
- CHKSOL N Y,PSBSOLS ; Check solut(s)
- I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q ; no sols
- S Y="" F S Y=$O(PSBOTMP("SOL",Y)) Q:Y="" K PSBSOL,PSBVOL S PSBSOL=$P(PSBOTMP("SOL",Y),U,2),PSBVOL=$P(PSBOTMP("SOL",Y),U,4),PSBSOLS(PSBSOL,PSBVOL)=PSBOTMP("SOL",Y)
- S Y="" F S Y=$O(PSBSOLA(Y)) Q:Y="" D
- .K PSBSOL,PSBVOL S PSBSOL=$P(PSBSOLA(Y),U,2),PSBVOL=$P(PSBSOLA(Y),U,4)
- .I $D(PSBSOLS(PSBSOL,PSBVOL)) K PSBSOLS(PSBSOL,PSBVOL) Q
- .I '$D(PSBSOLS(PSBSOL)) S PSBTXT=PSBSOLA(Y),$P(PSBTXT,U,1)="",$P(PSBTXT,U,2)="",PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",PSBSOL)=" added"_$TR(PSBTXT,U," ")
- .E K PSBSOLS(PSBSOL) S PSBIVCHG(PSBXOR,PSBCHGDT,"VOLUME ",PSBSOL)=$P(PSBSOLA(Y),U,3)_" changed to "_$P(PSBSOLA(Y),U,4)
- S Y="" F S Y=$O(PSBSOLS(Y)) Q:Y="" S:'$D(PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",Y)) PSBTXT=PSBSOLS(Y,($O(PSBSOLS(Y,"")))),$P(PSBTXT,U,1)="",$P(PSBTXT,U,2)="",PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",Y)=" deleted"_$TR(PSBTXT,U," ")
- Q
- PSBNXACT(DFN,PORDN) ;
- N PSBDFN,PSBOR S PSBDFN=DFN,PSBOR=PORDN K PSBDID
- S PSBNXACT="" I (PSBDFN="")!(PSBOR="")!(PSBOR'["P") Q PSBNXACT
- F Q:PSBOR="" Q:$D(PSBDID(PSBOR)) D
- .K ^TMP("PSJ1",$J) D EN^PSJBCMA1(PSBDFN,PSBOR,1) S PSBOR=$P(^TMP("PSJ1",$J,0),U,5) K ^TMP("PSJ1",$J)
- .I $G(PSBOR)]"",$G(PSBOR)'["P" S PSBNXACT=PSBOR S PSBOR=""
- .E S:$G(PSBOR)]"" (PSBNXACT,PSBDID($G(PSBOR)))=""
- .K ^TMP("PSJ1",$J)
- I PSBNXACT="" D EN^PSJBCMA1(PSBDFN,PSBLOR,1) I $P(^TMP("PSJ1",$J,4),U,7)<PSBDT K PSBBAGD(PSBXOR),PSBBUIDS(PSBXOR),PSBIVCHG(PSBXOR)
- Q PSBNXACT
- NEWDATA(PSBPARM) ;
- S NEWDATA="" N PSBDX S PSBDX="",PSBDX=$O(PSBIVCHG(PSBXOR,PSBDX),-1)
- F S PSBDX=$O(PSBIVCHG(PSBXOR,PSBDX),-1) Q:PSBDX="" D:$D(PSBIVCHG(PSBXOR,PSBDX,PSBPARM)) Q:PSBDX=""
- .S PSBIVCHG(PSBXOR,PSBDX,PSBPARM)=" changed to "_$G(^TMP("PSJ2",$J,PSBX,2)),PSBDX=""
- I $G(PSBPARM)="INFUSION RATE" Q $P(^TMP("PSJ1",$J,2),U,4)
- I $G(PSBPARM)="MED ROUTE" Q $P(^TMP("PSJ1",$J,1),U,13)
- I $G(PSBPARM)="PROVIDER" Q $P(^TMP("PSJ1",$J,1),U,2)
- I $G(PSBPARM)="REMARKS" Q $G(^TMP("PSJ1",$J,6))
- I $G(PSBPARM)="OTHER PRINT INFO" Q $G(^TMP("PSJ1",$J,3))
- I $G(PSBPARM)="STOP DATE/TIME" Q $P(^TMP("PSJ1",$J,4),U,8)
- I $G(PSBPARM)="START DATE/TIME" Q $P(^TMP("PSJ1",$J,4),U,6)
- Q NEWDATA
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBCHKIV 9782 printed Jan 18, 2025@02:41:14 Page 2
- PSBCHKIV ;BIRMINGHAM/TEJ-BCMA CHECK IV ROUTINE ;Mar 2004
- +1 ;;3.0;BAR CODE MED ADMIN;**16**;Mar 2004
- +2 ;
- +3 ;This routine will provide "change" details for infus or stopped IV bags.
- +4 ;
- +5 ; Reference/IA
- +6 ; EN^PSJBCMA1/2829
- +7 ; EN^PSJBCMA2/2830
- +8 ;
- RPC(RESULTS,DFN,ORDIV) ;
- +1 IF '$DATA(ORDIV)
- SET RESULTS(0)=0
- QUIT
- +2 NEW PSBGNODE,PSBPIN,PSBXX,PSBX,PSBBUIDS,PSBBUID
- KILL PSBBAGD,PSBADDS,PSBSOLS,RESULTS
- +3 DO NOW^%DTC
- SET X1=X
- SET X2=-3
- DO C^%DTC
- SET PSBDT=X
- +4 SET PSBPIN=DFN
- +5 SET Z=""
- FOR
- SET Z=$ORDER(ORDIV(Z))
- if Z=""
- QUIT
- Begin DoDot:1
- +6 DO GETORD^PSBCHIVH(ORDIV(Z))
- +7 FOR S=1:1
- if $PIECE(PSBONXSB,"^",S)=""
- QUIT
- Begin DoDot:2
- +8 SET PSBORD=$PIECE(PSBONXSB,"^",S)
- +9 SET PSBGNODE="^PSB(53.79,"_"""AUID"""_","_DFN_")"
- +10 FOR
- SET PSBGNODE=$QUERY(@PSBGNODE)
- if PSBGNODE=""
- QUIT
- if $QSUBSCRIPT(PSBGNODE,3)'=DFN
- QUIT
- Begin DoDot:3
- +11 IF $QSUBSCRIPT(PSBGNODE,4)=PSBORD
- Begin DoDot:4
- +12 SET PSBBIEN=$QSUBSCRIPT(PSBGNODE,6)
- +13 SET PSBSTATS=$PIECE(^PSB(53.79,PSBBIEN,0),U,9)
- if (PSBSTATS="I")!(PSBSTATS="S")
- Begin DoDot:5
- +14 SET PSBBUID=$QSUBSCRIPT(PSBGNODE,5)
- SET PSBOR=$$FNDLBLO^PSBVDLU2(PSBPIN,$QSUBSCRIPT(PSBGNODE,4),PSBBUID)
- SET (PSBXOR,PSBLOR)=PSBOR
- +15 ; G IV bag
- +16 ; IS ORD is "live"
- +17 SET PSBNXOR=PSBOR
- +18 SET PSBSTOP=0
- FOR
- KILL ^TMP("PSJ1",$JOB)
- DO EN^PSJBCMA1(DFN,PSBNXOR,1)
- if ($PIECE(^TMP("PSJ1",$JOB,0),U,5)']"")&($PIECE($GET(^TMP("PSJ1",$JOB,4)),U,7)<PSBDT)
- SET PSBSTOP=1
- if PSBNXOR=$PIECE(^TMP("PSJ1",$JOB,0),U,5)
- QUIT
- SET PSBNXOR=$PIECE(^TMP("PSJ1",$JOB,0),U,5)
- if PSBNXOR']""
- QUIT
- +19 ;
- IF 'PSBSTOP
- FOR PSBXX=1:1
- Begin DoDot:6
- +20 KILL ^TMP("PSJ1",$JOB)
- DO EN^PSJBCMA1(DFN,PSBOR,1)
- +21 SET PSBDX=""
- FOR
- SET PSBDX=$ORDER(^TMP("PSJ1",$JOB,PSBDX))
- if PSBDX=""
- QUIT
- IF $DATA(^TMP("PSJ1",$JOB,PSBDX,1000,PSBBUID))
- SET PSBLABDT=$PIECE(^TMP("PSJ1",$JOB,PSBDX,1000,PSBBUID,0),U)
- QUIT
- +22 KILL ^TMP("PSJ2",$JOB)
- DO EN^PSJBCMA2(DFN,PSBOR,1)
- if $DATA(^TMP("PSJ2",$JOB))
- Begin DoDot:7
- +23 SET PSBX=0
- FOR
- SET PSBX=$ORDER(^TMP("PSJ2",$JOB,PSBX))
- if PSBX=""
- QUIT
- if $PIECE(^TMP("PSJ2",$JOB,PSBX,1),U,3)]""
- Begin DoDot:8
- +24 SET PSBCHGDT=$PIECE(^TMP("PSJ2",$JOB,PSBX,1),U)
- SET PSBPARAM=$PIECE(^TMP("PSJ2",$JOB,PSBX,1),U,3)
- +25 IF ($PIECE(^TMP("PSJ2",$JOB,PSBX,1),U)'<$GET(PSBLABDT))
- SET PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)=" changed to "
- SET PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)=PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)_$$NEWDATA(PSBPARAM)
- End DoDot:8
- End DoDot:7
- +26 MERGE PSBBAGD(PSBXOR,PSBXX,0)=^TMP("PSJ1",$JOB,0),PSBBAGD(PSBXOR,PSBXX,4)=^TMP("PSJ1",$JOB,4),PSBBAGD(PSBXOR,PSBXX,2)=^TMP("PSJ1",$JOB,2)
- +27 FOR PSBX=800,850,900,950,1000
- Begin DoDot:7
- +28 IF "800900"[PSBX
- MERGE PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$JOB,PSBX,PSBBUID)
- +29 IF ("850950"[PSBX)
- IF '$DATA(PSBBAGD(PSBXOR,PSBXX,(PSBX-50),PSBBUID))
- MERGE PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$JOB,PSBX)
- +30 if PSBXX=1
- SET PSBBUIDS(PSBXOR,PSBBUID)=PSBXOR_U_PSBBUID_U_($PIECE(PSBBAGD(PSBXOR,PSBXX,2),U,2))_U_PSBSTATS
- +31 if (PSBXX=1)
- Begin DoDot:8
- +32 IF (PSBX=800)
- FOR PSBXY=0
- SET PSBXY=$ORDER(PSBBAGD(PSBXOR,1,800,PSBBUID,PSBXY))
- if PSBXY=""
- QUIT
- SET PSBBUIDS(PSBXOR,PSBBUID,"ADD",PSBXY)="ADD"_U_PSBBAGD(PSBXOR,1,800,PSBBUID,PSBXY)
- +33 IF (PSBX=900)
- FOR PSBXY=0
- SET PSBXY=$ORDER(PSBBAGD(PSBXOR,1,900,PSBBUID,PSBXY))
- if PSBXY=""
- QUIT
- SET PSBBUIDS(PSBXOR,PSBBUID,"SOL",PSBXY)="SOL"_U_PSBBAGD(PSBXOR,1,900,PSBBUID,PSBXY)
- +34 IF (PSBX=850)
- FOR PSBXY=0
- SET PSBXY=$ORDER(PSBBAGD(PSBXOR,1,850,PSBBUID,PSBXY))
- if PSBXY=""
- QUIT
- SET PSBBUIDS(PSBXOR,PSBBUID,"ADD",PSBXY)="ADD"_U_PSBBAGD(PSBXOR,1,850,PSBBUID,PSBXY,0)
- +35 IF (PSBX=950)
- FOR PSBXY=0
- SET PSBXY=$ORDER(PSBBAGD(PSBXOR,1,950,PSBBUID,PSBXY))
- if PSBXY=""
- QUIT
- SET PSBBUIDS(PSBXOR,PSBBUID,"SOL",PSBXY)="SOL"_U_PSBBAGD(PSBXOR,1,950,PSBBUID,PSBXY,0)
- End DoDot:8
- End DoDot:7
- +36 SET PSBLOR=$PIECE(^TMP("PSJ1",$JOB,0),U,3)
- SET PSBOR=$PIECE(^TMP("PSJ1",$JOB,0),U,5)
- KILL ^TMP("PSJ1",$JOB)
- +37 IF PSBOR["P"
- SET PSBOR=$$PSBNXACT(PSBPIN,PSBOR)
- End DoDot:6
- KILL ^TMP("PSJ1",$JOB)
- if PSBOR=""
- SET PSBCO(PSBXOR)=PSBLOR
- if PSBOR=""
- QUIT
- End DoDot:5
- QUIT
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +38 SET (PSBLINES,RESULTS(0))=0
- +39 if $GET(PSBGNODE)=""
- QUIT
- +40 IF $DATA(PSBBAGD)
- SET PSBXOR=""
- FOR
- SET PSBXOR=$ORDER(PSBBAGD(PSBXOR))
- if PSBXOR=""
- QUIT
- Begin DoDot:1
- +41 SET PSBXX=$ORDER(PSBBAGD(PSBXOR,""),-1)
- +42 ; "Whole of" order exp 3 dAYS ago proc nxt
- IF $PIECE(PSBBAGD(PSBXOR,PSBXX,4),U,7)<PSBDT
- SET PSBLINES=0
- QUIT
- +43 FOR PSBXX=1:1:($ORDER(PSBBAGD(PSBXOR,""),-1)-1)
- SET PSBXY=PSBXX+1
- if $DATA(PSBBAGD(PSBXOR,PSBXY))
- Begin DoDot:2
- +44 DO CLEAN^PSBVT
- DO PSJ1^PSBVT(PSBPIN,$PIECE(PSBBAGD(PSBXOR,PSBXX,0),U,3))
- +45 KILL PSBOTMP
- +46 IF $DATA(PSBADA)
- MERGE PSBOTMP("ADD")=PSBADA
- IF '$TEST
- SET PSBOTMP("ADD")=""
- +47 ;solut,vol
- IF $DATA(PSBSOLA)
- MERGE PSBOTMP("SOL")=PSBSOLA
- IF '$TEST
- SET PSBOTMP("SOL")=""
- +48 KILL PSBADA,PSBSOLA
- +49 SET PSBOTMP("INFUSION RATE")=$GET(PSBIFR)
- +50 SET PSBOTMP("MED ROUTE")=$GET(PSBMR)
- +51 SET PSBOTMP("REMARKS")=$GET(PSBRMRK)
- +52 SET PSBOTMP("OTHER PRINT INFO")=$GET(PSBOTXT)
- +53 SET PSBOTMP("PROVIDER")=PSBMD
- +54 SET PSBOTMP("START DATE/TIME")=PSBOST
- +55 SET PSBOTMP("STOP DATE/TIME")=PSBOSP
- +56 DO CLEAN^PSBVT
- DO PSJ1^PSBVT(PSBPIN,$PIECE(PSBBAGD(PSBXOR,PSBXY,0),U,3))
- +57 DO EN^PSJBCMA2(PSBPIN,$PIECE(PSBBAGD(PSBXOR,PSBXY,0),U,3),1)
- if $PIECE(^TMP("PSJ2",$JOB,1,1),U)]""
- SET PSBCHGDT=$PIECE(^TMP("PSJ2",$JOB,1,1),U)
- +58 IF $DATA(PSBADA)!($DATA(PSBOTMP("ADD")))
- DO CHKADD
- +59 IF $DATA(PSBSOLA)!($DATA(PSBOTMP("SOL")))
- DO CHKSOL
- +60 IF PSBIFR'=PSBOTMP("INFUSION RATE")
- if PSBOTMP("INFUSION RATE")]""
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"INFUSION RATE")=" changed to "_PSBIFR
- +61 IF PSBMR'=PSBOTMP("MED ROUTE")
- if PSBMR'=PSBOTMP("MED ROUTE")]""
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"MED ROUTE")=" changed to "_PSBMR
- +62 IF PSBRMRK'=PSBOTMP("REMARKS")
- if PSBOTMP("REMARKS")]""
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"REMARKS")=" changed to "_PSBRMRK
- +63 IF PSBOTXT'=PSBOTMP("OTHER PRINT INFO")
- if PSBOTMP("OTHER PRINT INFO")]""
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"OTHER PRINT INFO")=" changed to "_PSBOTXT
- +64 IF PSBMD'=PSBOTMP("PROVIDER")
- if PSBOTMP("PROVIDER")]""
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"PROVIDER")=" changed to "_PSBMDX
- +65 IF $EXTRACT(PSBOST,1,12)'=$EXTRACT(PSBOTMP("START DATE/TIME"),1,12)
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"START DATE/TIME")=" changed to "_PSBOSTX
- +66 IF $EXTRACT(PSBOSP,1,12)'=$EXTRACT(PSBOTMP("STOP DATE/TIME"),1,12)
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"STOP DATE/TIME")=" changed to "_PSBOSPX
- +67 DO CLEAN^PSBVT
- End DoDot:2
- End DoDot:1
- +68 ; Get RESULTS
- +69 if $DATA(PSBIVCHG)
- Begin DoDot:1
- +70 SET PSBXX=""
- FOR
- SET PSBXX=$ORDER(PSBIVCHG(PSBXX))
- if PSBLINES>0
- SET PSBLINES=PSBLINES+1
- SET RESULTS(PSBLINES)="END"
- SET RESULTS(0)=PSBLINES
- if PSBXX=""
- QUIT
- Begin DoDot:2
- +71 SET PSBXY=""
- FOR
- SET PSBXY=$ORDER(PSBBUIDS(PSBXX,PSBXY))
- if PSBXY=""
- QUIT
- Begin DoDot:3
- +72 SET PSBLINES=PSBLINES+1
- SET RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY)_U_PSBCO(PSBXX)
- +73 SET PSBXZ=0
- FOR
- SET PSBXZ=$ORDER(PSBBUIDS(PSBXX,PSBXY,"ADD",PSBXZ))
- if PSBXZ=""
- QUIT
- SET PSBLINES=PSBLINES+1
- SET RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY,"ADD",PSBXZ)
- +74 SET PSBXZ=0
- FOR
- SET PSBXZ=$ORDER(PSBBUIDS(PSBXX,PSBXY,"SOL",PSBXZ))
- if PSBXZ=""
- QUIT
- SET PSBLINES=PSBLINES+1
- SET RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY,"SOL",PSBXZ)
- End DoDot:3
- +75 SET PSBXY=""
- FOR
- SET PSBXY=$ORDER(PSBIVCHG(PSBXX,PSBXY),-1)
- if PSBXY=""
- QUIT
- Begin DoDot:3
- +76 SET PSBXZ=""
- FOR
- SET PSBXZ=$ORDER(PSBIVCHG(PSBXX,PSBXY,PSBXZ))
- if PSBXZ=""
- QUIT
- Begin DoDot:4
- +77 IF '("ADDITIVE STRENGTH SOLUTION VOLUME "[PSBXZ)
- SET PSBLINES=PSBLINES+1
- SET RESULTS(PSBLINES)="CD"_U_PSBXY_U_PSBXZ_PSBIVCHG(PSBXX,PSBXY,PSBXZ)
- +78 IF "ADDITIVE STRENGTH SOLUTION VOLUME "[PSBXZ
- SET PSBZX=""
- FOR
- SET PSBZX=$ORDER(PSBIVCHG(PSBXX,PSBXY,PSBXZ,PSBZX))
- if PSBZX=""
- QUIT
- SET PSBLINES=PSBLINES+1
- SET RESULTS(PSBLINES)="CD"_U_PSBXY_U_PSBXZ_PSBIVCHG(PSBXX,PSBXY,PSBXZ,PSBZX)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +79 KILL PSBIVCHG,PSBLINES,PSBBAGD,PSBAD,PSBSOL
- +80 QUIT
- CHKADD ; Check addit(s)
- NEW X,PSBADDS
- +1 ; no adds
- IF '$DATA(PSBADA)
- IF '$DATA(PSBOTMP("ADD"))
- QUIT
- +2 SET X=""
- FOR
- SET X=$ORDER(PSBOTMP("ADD",X))
- if X=""
- QUIT
- KILL PSBAD,PSBSTR
- SET PSBAD=$PIECE(PSBOTMP("ADD",X),U,2)
- SET PSBSTR=$PIECE(PSBOTMP("ADD",X),U,4)
- SET PSBADDS(PSBAD,PSBSTR)=PSBOTMP("ADD",X)
- +3 SET X=""
- FOR
- SET X=$ORDER(PSBADA(X))
- if X=""
- QUIT
- Begin DoDot:1
- +4 KILL PSBAD,PSBSTR
- SET PSBAD=$PIECE(PSBADA(X),U,2)
- SET PSBSTR=$PIECE(PSBADA(X),U,4)
- +5 IF $DATA(PSBADDS(PSBAD,PSBSTR))
- KILL PSBADDS(PSBAD,PSBSTR)
- QUIT
- +6 IF '$DATA(PSBADDS(PSBAD))
- SET PSBTXT=PSBADA(X)
- SET $PIECE(PSBTXT,U,1)=""
- SET $PIECE(PSBTXT,U,2)=""
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"ADDITIVE",PSBAD)=" added"_$TRANSLATE(PSBTXT,U," ")
- +7 IF '$TEST
- KILL PSBADDS(PSBAD)
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"STRENGTH ",PSBAD)=$PIECE(PSBADA(X),U,3)_" changed to "_$PIECE(PSBADA(X),U,4)
- End DoDot:1
- +8 SET X=""
- FOR
- SET X=$ORDER(PSBADDS(X))
- if X=""
- QUIT
- IF '$DATA(PSBIVCHG(PSBXOR,PSBCHGDT,"ADDITIVE",X))
- SET PSBTXT=PSBADDS(X,($ORDER(PSBADDS(X,""))))
- SET $PIECE(PSBTXT,U,1)=""
- SET $PIECE(PSBTXT,U,2)=""
- SET PSBIVCHG(PSBXOR,PSBOST,"ADDITIVE",X)=" deleted"_$TRANSLATE(PSBTXT,U," ")
- +9 QUIT
- CHKSOL ; Check solut(s)
- NEW Y,PSBSOLS
- +1 ; no sols
- IF '$DATA(PSBSOLA)
- IF '$DATA(PSBOTMP("SOL"))
- QUIT
- +2 SET Y=""
- FOR
- SET Y=$ORDER(PSBOTMP("SOL",Y))
- if Y=""
- QUIT
- KILL PSBSOL,PSBVOL
- SET PSBSOL=$PIECE(PSBOTMP("SOL",Y),U,2)
- SET PSBVOL=$PIECE(PSBOTMP("SOL",Y),U,4)
- SET PSBSOLS(PSBSOL,PSBVOL)=PSBOTMP("SOL",Y)
- +3 SET Y=""
- FOR
- SET Y=$ORDER(PSBSOLA(Y))
- if Y=""
- QUIT
- Begin DoDot:1
- +4 KILL PSBSOL,PSBVOL
- SET PSBSOL=$PIECE(PSBSOLA(Y),U,2)
- SET PSBVOL=$PIECE(PSBSOLA(Y),U,4)
- +5 IF $DATA(PSBSOLS(PSBSOL,PSBVOL))
- KILL PSBSOLS(PSBSOL,PSBVOL)
- QUIT
- +6 IF '$DATA(PSBSOLS(PSBSOL))
- SET PSBTXT=PSBSOLA(Y)
- SET $PIECE(PSBTXT,U,1)=""
- SET $PIECE(PSBTXT,U,2)=""
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",PSBSOL)=" added"_$TRANSLATE(PSBTXT,U," ")
- +7 IF '$TEST
- KILL PSBSOLS(PSBSOL)
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"VOLUME ",PSBSOL)=$PIECE(PSBSOLA(Y),U,3)_" changed to "_$PIECE(PSBSOLA(Y),U,4)
- End DoDot:1
- +8 SET Y=""
- FOR
- SET Y=$ORDER(PSBSOLS(Y))
- if Y=""
- QUIT
- if '$DATA(PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",Y))
- SET PSBTXT=PSBSOLS(Y,($ORDER(PSBSOLS(Y,""))))
- SET $PIECE(PSBTXT,U,1)=""
- SET $PIECE(PSBTXT,U,2)=""
- SET PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",Y)=" deleted"_$TRANSLATE(PSBTXT,U," ")
- +9 QUIT
- PSBNXACT(DFN,PORDN) ;
- +1 NEW PSBDFN,PSBOR
- SET PSBDFN=DFN
- SET PSBOR=PORDN
- KILL PSBDID
- +2 SET PSBNXACT=""
- IF (PSBDFN="")!(PSBOR="")!(PSBOR'["P")
- QUIT PSBNXACT
- +3 FOR
- if PSBOR=""
- QUIT
- if $DATA(PSBDID(PSBOR))
- QUIT
- Begin DoDot:1
- +4 KILL ^TMP("PSJ1",$JOB)
- DO EN^PSJBCMA1(PSBDFN,PSBOR,1)
- SET PSBOR=$PIECE(^TMP("PSJ1",$JOB,0),U,5)
- KILL ^TMP("PSJ1",$JOB)
- +5 IF $GET(PSBOR)]""
- IF $GET(PSBOR)'["P"
- SET PSBNXACT=PSBOR
- SET PSBOR=""
- +6 IF '$TEST
- if $GET(PSBOR)]""
- SET (PSBNXACT,PSBDID($GET(PSBOR)))=""
- +7 KILL ^TMP("PSJ1",$JOB)
- End DoDot:1
- +8 IF PSBNXACT=""
- DO EN^PSJBCMA1(PSBDFN,PSBLOR,1)
- IF $PIECE(^TMP("PSJ1",$JOB,4),U,7)<PSBDT
- KILL PSBBAGD(PSBXOR),PSBBUIDS(PSBXOR),PSBIVCHG(PSBXOR)
- +9 QUIT PSBNXACT
- NEWDATA(PSBPARM) ;
- +1 SET NEWDATA=""
- NEW PSBDX
- SET PSBDX=""
- SET PSBDX=$ORDER(PSBIVCHG(PSBXOR,PSBDX),-1)
- +2 FOR
- SET PSBDX=$ORDER(PSBIVCHG(PSBXOR,PSBDX),-1)
- if PSBDX=""
- QUIT
- if $DATA(PSBIVCHG(PSBXOR,PSBDX,PSBPARM))
- Begin DoDot:1
- +3 SET PSBIVCHG(PSBXOR,PSBDX,PSBPARM)=" changed to "_$GET(^TMP("PSJ2",$JOB,PSBX,2))
- SET PSBDX=""
- End DoDot:1
- if PSBDX=""
- QUIT
- +4 IF $GET(PSBPARM)="INFUSION RATE"
- QUIT $PIECE(^TMP("PSJ1",$JOB,2),U,4)
- +5 IF $GET(PSBPARM)="MED ROUTE"
- QUIT $PIECE(^TMP("PSJ1",$JOB,1),U,13)
- +6 IF $GET(PSBPARM)="PROVIDER"
- QUIT $PIECE(^TMP("PSJ1",$JOB,1),U,2)
- +7 IF $GET(PSBPARM)="REMARKS"
- QUIT $GET(^TMP("PSJ1",$JOB,6))
- +8 IF $GET(PSBPARM)="OTHER PRINT INFO"
- QUIT $GET(^TMP("PSJ1",$JOB,3))
- +9 IF $GET(PSBPARM)="STOP DATE/TIME"
- QUIT $PIECE(^TMP("PSJ1",$JOB,4),U,8)
- +10 IF $GET(PSBPARM)="START DATE/TIME"
- QUIT $PIECE(^TMP("PSJ1",$JOB,4),U,6)
- +11 QUIT NEWDATA