PSBMD ;BIRMINGHAM/EFC - BCMA MISSING DOSE FUNCTIONS ;4/23/21 08:34
;;3.0;BAR CODE MED ADMIN;**23,42,70,100,111,106,132**;Mar 2004;Build 1
;
; Reference/IA
; ^DIC(42/10039
; ^DPT(/10035
; IN5^VADPT/10061
; DEM^VADPT/10061
; ^XMB/10070
; 52.6/436
; 52.7/437
; ^DG(40.8/417
; 4/2171
; ^DG(40.8/2817
; ^VA(200/10060
; ^DIC(4/10090
; ^DG(43/6812
;
;*70 - add new kernel variable for CO Missing Dose Printer.
; use Clinc name if passed in for the new field Clinic or
; assume Ward and get ien.
;*106- add Hazardous Handle & Dispose flags
;
RPC(RESULTS,PSBDFN,PSBDRUG,PSBDOSE,PSBRSN,PSBADMIN,PSBNEED,PSBUID,PSBON,PSBSCHD,PSBCLIN,PSBCLNIEN) ;
;
; RPC: PSB SUBMIT MISSING DOSE
;
; Description:
; Allows the client to submit a missing dose interactively
;
N DFN,PSBNOW,PSBFDA,PSBIENS,PSBMD,PSBMSG
S PSBCLNIEN=+$G(PSBCLNIEN) ;*70 insure numeric
D NEW(.PSBMD)
I +PSBMD(0)<1 S RESULTS(0)="-1^Unable to create missing dose request" Q
S PSBIENS=+PSBMD(0)_","
D NOW^%DTC S PSBNOW=%
S PSBFDA(53.68,PSBIENS,.02)=PSBNOW
S PSBFDA(53.68,PSBIENS,.03)=DUZ
S PSBFDA(53.68,PSBIENS,.04)=DUZ(2)
S PSBFDA(53.68,PSBIENS,.11)=PSBDFN
; Ward or Clinic - use Clinic name if passed, else get Ward ien. *70
I PSBCLIN]"" D
.S PSBFDA(53.68,PSBIENS,1)=PSBCLNIEN
E D
.S X=$G(^DPT(PSBDFN,.1))
.I X]"" S X=$O(^DIC(42,"B",X,0)) S:X PSBFDA(53.68,PSBIENS,.12)=X
.S DFN=PSBDFN D IN5^VADPT S PSBFDA(53.68,PSBIENS,.18)=$P(VAIP(6),U,1)
S PSBFDA(53.68,PSBIENS,.13)=PSBDRUG
S PSBFDA(53.68,PSBIENS,.14)=PSBDOSE
S PSBFDA(53.68,PSBIENS,.15)=PSBRSN
S PSBFDA(53.68,PSBIENS,.16)=PSBADMIN
S PSBFDA(53.68,PSBIENS,.17)=PSBNEED
S PSBFDA(53.68,PSBIENS,.19)=PSBSCHD
S PSBFDA(53.68,PSBIENS,.25)=PSBUID
D FILE^DIE("","PSBFDA","PSBMSG")
L +^PSB(53.68,+PSBIENS):$S($G(DILOCKTM)>0:DILOCKTM,1:3) ; PSB*3*23
I $G(PSBUID)'="" D
.D PSJ1^PSBVT(PSBDFN,PSBON) K PSBADA,PSBSOLA
.I '$D(PSBUIDA(PSBUID)) F D PSJ1^PSBVT(PSBDFN,PSBPONX) K PSBADA,PSBSOLA Q:$D(PSBUIDA(PSBUID)) Q:PSBPONX=""
.F I=1:1 S PSBAD=$P(PSBUIDA(PSBUID),U,I) Q:PSBAD="" I PSBAD["ADD" S PSBADA($P(PSBAD,";",2))=""
.I $D(PSBADA) S X="" F I=1:1 S X=$O(PSBADA(X)) Q:X="" S PSBFDA(53.686,I_","_PSBIENS,.01)=X,^PSB(53.68,+PSBIENS,.6,I,0)=0 ;p132
.F I=1:1 S PSBSOL=$P(PSBUIDA(PSBUID),U,I) Q:PSBSOL="" I PSBSOL["SOL" S PSBSOLA($P(PSBSOL,";",2))=""
.I $D(PSBSOLA) S X="" F I=1:1 S X=$O(PSBSOLA(X)) Q:X="" S PSBFDA(53.687,I_","_PSBIENS,.01)=X,^PSB(53.68,+PSBIENS,.7,I,0)=0 ;p132
I $G(PSBUID)="",$G(PSBDRUG)="" D
.D PSJ1^PSBVT(PSBDFN,PSBON)
.I $D(PSBADA) S X="" F I=1:1 S X=$O(PSBADA(X)) Q:X="" S PSBFDA(53.686,I_","_PSBIENS,.01)=$P(PSBADA(X),U,2),^PSB(53.68,+PSBIENS,.6,I,0)=0 ;p132
.I $D(PSBSOLA) S X="" F I=1:1 S X=$O(PSBSOLA(X)) Q:X="" S PSBFDA(53.687,I_","_PSBIENS,.01)=$P(PSBSOLA(X),U,2),^PSB(53.68,+PSBIENS,.7,I,0)=0 ;p132
D FILE^DIE("","PSBFDA","PSBMSG")
L -^PSB(53.68,+PSBIENS) ; PSB83*23
D SUBMIT(+PSBIENS)
S RESULTS(0)="1^Missing Dose Submitted^"_+PSBIENS
D CLEAN^PSBVT
Q
;
XQ ; Called via Kernel Menus
N PSBMD,PSBSAVE,DA,DIK,DR,DDSFILE,XMY,XMTEXT,XMSUB
D NEW(.PSBMD)
I +PSBMD(0)<1 W !,"Error: ",$P(PSBMD(0),U,2) S DIR(0)="E" D ^DIR Q
S DA=+PSBMD(0),DR="[PSB MISSING DOSE REQUEST]",DDSFILE=53.68 D ^DDS
W @IOF
I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.68," D ^DIK W "Cancelled!"
D:PSBSAVE SUBMIT(DA)
Q
;
SUBMIT(DA) ; Submit Request to Pharmacy
N PSBWRD,PSBMG,PSBPRT,CLIEN
S PSBWRD=$P(^PSB(53.68,DA,.1),U,2)
S PSBWRD=+$G(^DIC(42,+PSBWRD,44))
I PSBCLIN]"" S CLIEN=+$O(^PS(53.46,"B",PSBCLNIEN,""))
;
; Get Mail Group
;
S PSBMG=$$GET^XPAR(PSBWRD_";SC(","PSB MG MISSING DOSE",,"E")
S:PSBMG="" PSBMG=$$GET^XPAR("DIV","PSB MG MISSING DOSE",,"E")
S $P(^PSB(53.68,DA,0),U,5)=PSBMG ; Add MG to notification
;
; Get Printer - If NO printer can be found, then DO NOT print!!
;*70 - get CO printer if Clinic orders, else IM med & get IM printer
; IM printer uses Variable PSB PRINTER MISSING DOSE
; CO printer can come from 3 sources:
; 1st from Clinic Defintion file for the specific Clinic if defined
; 2nd from the Variable PSB PRINTER CO MISSING DOSE if defined
; 3rd just use the IM med printer Variable.
;
D:PSBCLIN]"" ;*70
.S PSBPRT=$$GET1^DIQ(53.46,CLIEN,4)
.S:PSBPRT="" PSBPRT=$$GET^XPAR("DIV","PSB PRINTER CO MISSING DOSE",,"E")
.S:PSBPRT="" PSBPRT=$$GET^XPAR("DIV","PSB PRINTER MISSING DOSE",,"E")
D:PSBCLIN="" ;*70
.S PSBPRT=$$GET^XPAR(PSBWRD_";SC(","PSB PRINTER MISSING DOSE",,"E")
.S:PSBPRT="" PSBPRT=$$GET^XPAR("DIV","PSB PRINTER MISSING DOSE",,"E")
;
S $P(^PSB(53.68,DA,0),U,6)=PSBPRT ; Add MG to notification
;
; Send the report to the specified printer
;
D:PSBPRT]""
.W !,"Submitting Request To Pharmacy on device ",PSBPRT,"..."
.D NOW^%DTC
.S ZTIO=PSBPRT
.S ZTDTH=%
.S ZTDESC="BCMA - MISSING DOSE REQUEST"
.S ZTRTN="DQ^PSBMD("_DA_")"
.D ^%ZTLOAD
.W "Done!"
;
; Send the same stuff to the mail group
;
D:PSBMG]""
.W !,"Notifying Pharmacy via Mail Group ",PSBMG,"..."
.D HFSOPEN^PSBUTL("MISSING DOSE")
.U IO D DQ(DA,1)
.D HFSCLOSE^PSBUTL("MISSING DOSE")
.S XMY("G."_PSBMG)="",XMTEXT="^TMP(""PSBO"",$J,"
.S XMSUB="BCMA - Missing Dose Request"
.D ^XMD
.W "Done!"
Q
;
DQ(PSBMD,PSBMM) ; Dequeue report from Taskman
N PSBFLD,PSBRET,DDIEN
Q:'$D(^PSB(53.68,PSBMD,0))
L +^PSB(53.68,PSBMD):$S($G(DILOCKTM)>0:DILOCKTM,1:3) ; PSB*3*23
S PSBCFLD=$P(^PSB(53.68,PSBMD,.1),U,3)
L -^PSB(53.68,PSBMD) ; PSB*3*23
D:'$G(PSBMM) ; It is not a mail message
.W !,$TR($J("",75)," ","=")
.W !,"Report: MISSING DOSE REQUEST"
.W !,"Date Created: " D NOW^%DTC S Y=% D D^DIQ W Y
.W !,$TR($J("",75)," ","="),!
;I $G(PSBCFLD)'="" F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.13,.14,.19,.15,.16,.17 D OUT ;*70
;I $G(PSBCFLD)="" F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.25,.15,.19,.16,.17 D OUT ;*70
;I $D(^PSB(53.68,PSBMD,.6)) S X=0 F S X=$O(^PSB(53.68,PSBMD,.6,X)) Q:'X W !?3,"ADDITIVE: ",$$GET1^DIQ(52.6,+^PSB(53.68,PSBMD,.6,X,0),.01)
;I $D(^PSB(53.68,PSBMD,.7)) S X=0 F S X=$O(^PSB(53.68,PSBMD,.7,X)) Q:'X W !?3,"SOLUTION: ",$$GET1^DIQ(52.7,+^PSB(53.68,PSBMD,.7,X,0),.01)
I $G(PSBCFLD)'="" D ;*106 - added HAZ notifications for dispensed drugs
. F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.13 D OUT
. S DDIEN=$$GET1^DIQ(53.68,PSBMD,.13,"I") D HAZOUT(DDIEN,31)
. F PSBFLD=.14,.19,.15,.16,.17 D OUT ;*70
I $G(PSBCFLD)="" F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.25,.15,.19,.16,.17 D OUT ;*70
I $D(^PSB(53.68,PSBMD,.6)) S X=0 D ;*106 - added HAZ notifications for additives
. F S X=$O(^PSB(53.68,PSBMD,.6,X)) Q:'X W !?3,"ADDITIVE: ",$$GET1^DIQ(52.6,+^PSB(53.68,PSBMD,.6,X,0),.01) D
. . S DDIEN=$$GET1^DIQ(52.6,+^PSB(53.68,PSBMD,.6,X,0),1,"I") D HAZOUT(DDIEN,14)
I $D(^PSB(53.68,PSBMD,.7)) S X=0 D ;*106 - added HAZ notifications for solutions
. F S X=$O(^PSB(53.68,PSBMD,.7,X)) Q:'X W !?3,"SOLUTION: ",$$GET1^DIQ(52.7,+^PSB(53.68,PSBMD,.7,X,0),.01) D
. . S DDIEN=$$GET1^DIQ(52.7,+^PSB(53.68,PSBMD,.7,X,0),1,"I") D HAZOUT(DDIEN,14)
Q
OUT ;
D FIELD^DID(53.68,PSBFLD,"","LABEL","PSBRET")
W !?3,PSBRET("LABEL"),":" F Q:$X>30 W "."
W $$GET1^DIQ(53.68,PSBMD_",",PSBFLD)
I PSBFLD=.11 D
.N DFN,VA,VADM S DFN=$$GET1^DIQ(53.68,PSBMD_",",.11,"I") D DEM^VADPT
.W !?3,$$GET^XPAR("ALL","PSB PATIENT ID LABEL")
.I $G(DUZ("AG"))="I" D
..W ":" F Q:$X>30 W "."
.E D
..W " (LAST 4 NUMBERS):" F Q:$X>30 W "."
.W VA("BID")
W:PSBFLD=.13 " ("_$P($G(^PSB(53.68,PSBMD,.1)),U,3)_")"
S ZTREQ="@"
Q
;
HAZOUT(P50,POS) ; Write warnings for drugs, additives and solutions that are Hazardous to Handle or Dispose *106
N PSBHAZ
S PSBHAZ=$$HAZ^PSSUTIL(P50)
I $P(PSBHAZ,U)!$P(PSBHAZ,U,2) W !?POS W:$P(PSBHAZ,U) "<<HAZ Handle>> " W:$P(PSBHAZ,U,2) "<<HAZ Dispose>>"
Q
;
NEW(RESULTS) ; Create a new missing dose request
; Called interactively and via RPCBroker
N DIC
K RESULTS
I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
; Lock Log
L +^PSB(53.68,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
E S RESULTS(0)="-1^Request Log Locked" Q
; Generate Unique Entry and Create
F D NOW^%DTC S X=$E(%_"000000",1,14),X=(1700+$E(X,1,3))_$E(X,4,14),X="MD-"_$TR(X,".","-") Q:'$D(^PSB(53.68,"B",X))
S DIC="^PSB(53.68,",DIC(0)="L"
S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.07///1"
K D0 ;VRN
D FILE^DICN
L -^PSB(53.68,0)
; Okay, setup return and Boogie
I +Y<1 S RESULTS(0)="-1^Error Creating Request"
E S RESULTS(0)=Y
Q
;
VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
N PSB,PSBFLD,PSBMSG
F PSB=1:1 Q:$P(PSBFLDS,";",PSB)="" S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.68,DA,PSBFLD)
I $D(PSBFLD(.21)) K:PSBFLD(.21)="N" PSBFLD(.22),PSBFLD(.23)
S PSB="" F S PSB=$O(PSBFLD(PSB)) Q:PSB="" D:PSBFLD(PSB)=""
.I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED"
.D FIELD^DID(53.68,PSB,"","TITLE;LABEL","PSB")
.S X=" Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL")),PSBMSG($O(PSBMSG(""),-1)+1)=X
Q:'$D(PSBMSG) ; All is well
D MSG^DDSUTL(.PSBMSG)
S DDSERROR=1
Q
;
CHK1 ; Start PSB*3*100 changes: use 'DIVAS' cross ref for multidivision sites
; DUZ(2), the user's division, is set at sign-on. At multidivision sites where a user has access
; to multiple divisions, allow selection of a division from the divisions defined in file #40.8.
; The user must have at least one division from file #40.8 in his file #200 record.
K ^TMP("PSBMD",$J)
N DIR
W !
S DIR(0)="SB^A:All Divisions;O:One Division"
S DIR("?")="Select either All Divisions or One Division."
S DIR("A")="Do you want (A)ll Divisions or just (O)ne Division"
S DIR("B")="O"
D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) Q
I Y="" Q
I Y(0)="One Division" D ONE Q ; regardless user divisions in file #200
I Y(0)="All Divisions" D ALL Q
Q
;
ALL ; user gets all divisions (current behavior); applicable to single division sites as well
S Y(0)="All Divisions"
S PSBDIV=DUZ(2)
S PSBSTIEN=+$O(^DG(40.8,"AD",DUZ(2),"")) ; current IEN for station
S Y=$$GET1^DIQ(40.8,PSBSTIEN,.01,"E")
I '$D(Y) S Y=DUZ(2)
S PSBNAME=$$NAME^XUAF4(DUZ(2))
S PSBMUDV=0
S ^TMP("PSBMD",$J)=PSBMUDV_U_PSBDIV_U_PSBNAME
Q
;
ONE ; when user selects one division from many in file #200, look at file #40.8 for a match if available
W !
S PSBSTIEN=+$O(^DG(40.8,"AD",DUZ(2),"")) ; current IEN for station
S PSBDVNM=$$GET1^DIQ(40.8,PSBSTIEN,.01,"I") ;division name
S DIC("B")=PSBDVNM
S DIC("A")="Select Division: ",DIC="^DG(40.8,",DIC(0)="AEMQ",DIC("S")="I $$SITE^VASITE(,+Y)>0"
D ^DIC
; capture the division name and number after user selection
S PSBNAME=$$GET1^DIQ(40.8,+Y,.01,"E")
S PSBDPTR=$$GET1^DIQ(40.8,+Y,.07,"I") ; pointer to file #4
S PSBDIV=PSBDPTR
S ^TMP("PSBMD",$J)=PSBMUDV_U_PSBDIV_U_PSBNAME
Q
;end of changes for PSB*3*100
;
FLWUP ; Follow-Up on missing dose
; start PSB*3*100 changes
N D0,DIC,PSBDATA,PSBDPTR,PSBDIV,PSBDVNM,PSBNAME,PSBMUDV,PSBSTIEN,X,Y
S D0=1,PSBMUDV=$S($$GET1^DIQ(43,D0,11,"I")=1:1,1:0)
I $P($G(^VA(200,DUZ,2,0)),U,4)=0 W !!,$C(7),"You have no valid divisions in the NEW PERSON file." S Y="^" Q
I '$O(^DG(40.8,"AD",DUZ(2),"")) W !!,$C(7),"Your NEW PERSON file division was not found in the MEDICAL CENTER DIVISION file." S Y="^" Q
I PSBMUDV=1 D CHK1
I PSBMUDV=0 D ALL
I Y=""!(Y<0)!(Y="^") Q
S PSBDIV=$P($G(^TMP("PSBMD",$J)),U,2)
S PSBNAME=$P($G(^TMP("PSBMD",$J)),U,3)
; end of changes for PSB*3*100
N DIR,PSBIEN,PSBX,DA,DR,DDSFILE,PSBHDR,PSBDRUG,LOC ;*70
N PSBHAZ,DDIEN ;*106
S Y="" F Q:Y="^" D
.K ^TMP("PSB",$J) S X=""
.;start PSB*3*100 changes: user did not select one division and will see all the records (single station functionality)
.I $G(PSBMUDV)=0 D
..F S X=$O(^PSB(53.68,"AS",1,X),-1) Q:'X S Y=$O(^TMP("PSB",$J,""),-1)+1,^TMP("PSB",$J,Y)=X,^TMP("PSB",$J,0)=Y
.;
.; user selected one division
.I $G(PSBMUDV)=1 D
..F S X=$O(^PSB(53.68,"DIVAS",1,PSBDIV,X),-1) Q:'X S Y=$O(^TMP("PSB",$J,""),-1)+1,^TMP("PSB",$J,Y)=X,^TMP("PSB",$J,0)=Y
.;
.I '$O(^TMP("PSB",$J,0)) W !!,"No Unresolved Missing Dose Requests Found." S Y="^" Q
.I $G(PSBMUDV)=0 S PSBHDR="Currently Unresolved Missing Dose Requests"
.I $G(PSBMUDV)=1 S PSBHDR="Currently Unresolved Missing Dose Requests for: "_PSBNAME
.;end of changes for PSB*3*100
.W @IOF,PSBHDR,!,$TR($J("",IOM)," ","-")
.F PSBX=0:0 S PSBX=$O(^TMP("PSB",$J,PSBX)) Q:'PSBX!(Y="^") S PSBIEN=^(PSBX)_"," D
..W !,$J(PSBX,2),". ",$$GET1^DIQ(53.68,PSBIEN,.01)
..W ?25,$$GET1^DIQ(53.68,PSBIEN,.11)
..; get correct location ;*70
..S LOC=$S($$GET1^DIQ(53.68,PSBIEN,1)]"":$$GET1^DIQ(53.68,PSBIEN,1),1:$$GET1^DIQ(53.68,PSBIEN,.12))
..W ?57,LOC ;*70
..S PSBDRUG=$$GET1^DIQ(53.68,PSBIEN,.13),DDIEN=$$GET1^DIQ(53.68,PSBIEN,.13,"I") ;*106
..I PSBDRUG]"" S PSBHAZ=$$HAZ^PSSUTIL(DDIEN) W !?5,PSBDRUG I $P(PSBHAZ,U)!$P(PSBHAZ,U,2) W !?5 W:$P(PSBHAZ,U) "<<HAZ Handle>> " W:$P(PSBHAZ,U,2) "<<HAZ Dispose>>" ;*106
..I PSBDRUG="" D
...W !?5,"UNIQUE ID: ",$$GET1^DIQ(53.68,PSBIEN,.25)
...S X=0 F S X=$O(^PSB(53.68,+PSBIEN,.6,X)) Q:'X W !?10,"ADDITIVES: ",$$GET1^DIQ(52.6,+^PSB(53.68,+PSBIEN,.6,X,0),.01)
...S X=0 F S X=$O(^PSB(53.68,+PSBIEN,.7,X)) Q:'X W !?10,"SOLUTIONS: ",$$GET1^DIQ(52.7,+^PSB(53.68,+PSBIEN,.7,X,0),.01)
..S:$Y>(IOSL-5) Y=$$PAGE(PSBX) ;use -5 so if Haz added line displayed, as 3rd line, then needs to not scroll line 1 HDR off screen in some cases *106
.S:Y'="^" Y=$$PAGE(PSBX)
K ^TMP("PSB",$J),^TMP("PSBMD",$J) ; PSB*3*100
Q
;
PAGE(PSBIX) ;
;
N X,X1,PSBCX,PSBDX
S DIR("A")="Select Missing Dose Request # (<RET> to continue, '^' to quit)"
I PSBIX="" S DIR("A")="Select Missing Dose Request # (<RET> or '^' to quit)"
S DIR(0)="NO^1:"_$S(PSBIX="":$O(^TMP("PSB",$J,PSBX),-1),1:PSBIX)_":0"
D ^DIR S PSBDX=+Y
I PSBIX="",Y="" S Y="^" Q Y
I $G(DTOUT) S Y="^" Q Y
I Y="^" Q Y
I Y="" W @IOF,PSBHDR,!,$TR($J("",IOM)," ","-") Q Y
S (DA,PSBCX)=^TMP("PSB",$J,+Y),DR="[PSB MISSING DOSE FOLLOWUP]",DDSFILE=53.68
D Q Y
.D ^DDS
.; start changes for PSB*3*100
.I $G(PSBMUDV)=0,$D(^PSB(53.68,"AS",0,PSBCX)) K ^TMP("PSB",$J) S X="" F S X=$O(^PSB(53.68,"AS",1,X),-1) Q:'X S X1=$O(^TMP("PSB",$J,""),-1)+1,^TMP("PSB",$J,X1)=X,^TMP("PSB",$J,0)=X1
.I $G(PSBMUDV)=1,$D(^PSB(53.68,"DIVAS",0,PSBDIV)) K ^TMP("PSB",$J) S X="" F S X=$O(^PSB(53.68,"DIVAS",1,PSBDIV,X),-1) Q:'X S X1=$O(^TMP("PSB",$J,""),-1)+1,^TMP("PSB",$J,X1)=X,^TMP("PSB",$J,0)=X1
.; stop printing header twice (old bug) by checking PSBX before setting it to zero.
.I PSBX>0 S PSBX=0 W @IOF,PSBHDR,!,$TR($J("",IOM)," ","-")
; end of changes for PSB*3*100
;
POST ;call from 'Patient' field of screenman form PSB MISSING DOSE REQUEST
;
N DFN
S DFN=X D IN5^VADPT
D PUT^DDSVAL(DIE,.DA,.12,$P(VAIP(5),U,2)) ; value of DIE is 53.68, BCMA MISSING DOSE REQUEST FILE called from ScreenMan
D PUT^DDSVAL(DIE,.DA,.18,$P(VAIP(6),U,1),"","I") ; value of DIE is 53.68, BCMA MISSING DOSE REQUEST FILE called from ScreenMan
D REFRESH^DDSUTL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBMD 15487 printed Apr 09, 2024@20:44:36 Page 2
PSBMD ;BIRMINGHAM/EFC - BCMA MISSING DOSE FUNCTIONS ;4/23/21 08:34
+1 ;;3.0;BAR CODE MED ADMIN;**23,42,70,100,111,106,132**;Mar 2004;Build 1
+2 ;
+3 ; Reference/IA
+4 ; ^DIC(42/10039
+5 ; ^DPT(/10035
+6 ; IN5^VADPT/10061
+7 ; DEM^VADPT/10061
+8 ; ^XMB/10070
+9 ; 52.6/436
+10 ; 52.7/437
+11 ; ^DG(40.8/417
+12 ; 4/2171
+13 ; ^DG(40.8/2817
+14 ; ^VA(200/10060
+15 ; ^DIC(4/10090
+16 ; ^DG(43/6812
+17 ;
+18 ;*70 - add new kernel variable for CO Missing Dose Printer.
+19 ; use Clinc name if passed in for the new field Clinic or
+20 ; assume Ward and get ien.
+21 ;*106- add Hazardous Handle & Dispose flags
+22 ;
RPC(RESULTS,PSBDFN,PSBDRUG,PSBDOSE,PSBRSN,PSBADMIN,PSBNEED,PSBUID,PSBON,PSBSCHD,PSBCLIN,PSBCLNIEN) ;
+1 ;
+2 ; RPC: PSB SUBMIT MISSING DOSE
+3 ;
+4 ; Description:
+5 ; Allows the client to submit a missing dose interactively
+6 ;
+7 NEW DFN,PSBNOW,PSBFDA,PSBIENS,PSBMD,PSBMSG
+8 ;*70 insure numeric
SET PSBCLNIEN=+$GET(PSBCLNIEN)
+9 DO NEW(.PSBMD)
+10 IF +PSBMD(0)<1
SET RESULTS(0)="-1^Unable to create missing dose request"
QUIT
+11 SET PSBIENS=+PSBMD(0)_","
+12 DO NOW^%DTC
SET PSBNOW=%
+13 SET PSBFDA(53.68,PSBIENS,.02)=PSBNOW
+14 SET PSBFDA(53.68,PSBIENS,.03)=DUZ
+15 SET PSBFDA(53.68,PSBIENS,.04)=DUZ(2)
+16 SET PSBFDA(53.68,PSBIENS,.11)=PSBDFN
+17 ; Ward or Clinic - use Clinic name if passed, else get Ward ien. *70
+18 IF PSBCLIN]""
Begin DoDot:1
+19 SET PSBFDA(53.68,PSBIENS,1)=PSBCLNIEN
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 SET X=$GET(^DPT(PSBDFN,.1))
+22 IF X]""
SET X=$ORDER(^DIC(42,"B",X,0))
if X
SET PSBFDA(53.68,PSBIENS,.12)=X
+23 SET DFN=PSBDFN
DO IN5^VADPT
SET PSBFDA(53.68,PSBIENS,.18)=$PIECE(VAIP(6),U,1)
End DoDot:1
+24 SET PSBFDA(53.68,PSBIENS,.13)=PSBDRUG
+25 SET PSBFDA(53.68,PSBIENS,.14)=PSBDOSE
+26 SET PSBFDA(53.68,PSBIENS,.15)=PSBRSN
+27 SET PSBFDA(53.68,PSBIENS,.16)=PSBADMIN
+28 SET PSBFDA(53.68,PSBIENS,.17)=PSBNEED
+29 SET PSBFDA(53.68,PSBIENS,.19)=PSBSCHD
+30 SET PSBFDA(53.68,PSBIENS,.25)=PSBUID
+31 DO FILE^DIE("","PSBFDA","PSBMSG")
+32 ; PSB*3*23
LOCK +^PSB(53.68,+PSBIENS):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+33 IF $GET(PSBUID)'=""
Begin DoDot:1
+34 DO PSJ1^PSBVT(PSBDFN,PSBON)
KILL PSBADA,PSBSOLA
+35 IF '$DATA(PSBUIDA(PSBUID))
FOR
DO PSJ1^PSBVT(PSBDFN,PSBPONX)
KILL PSBADA,PSBSOLA
if $DATA(PSBUIDA(PSBUID))
QUIT
if PSBPONX=""
QUIT
+36 FOR I=1:1
SET PSBAD=$PIECE(PSBUIDA(PSBUID),U,I)
if PSBAD=""
QUIT
IF PSBAD["ADD"
SET PSBADA($PIECE(PSBAD,";",2))=""
+37 ;p132
IF $DATA(PSBADA)
SET X=""
FOR I=1:1
SET X=$ORDER(PSBADA(X))
if X=""
QUIT
SET PSBFDA(53.686,I_","_PSBIENS,.01)=X
SET ^PSB(53.68,+PSBIENS,.6,I,0)=0
+38 FOR I=1:1
SET PSBSOL=$PIECE(PSBUIDA(PSBUID),U,I)
if PSBSOL=""
QUIT
IF PSBSOL["SOL"
SET PSBSOLA($PIECE(PSBSOL,";",2))=""
+39 ;p132
IF $DATA(PSBSOLA)
SET X=""
FOR I=1:1
SET X=$ORDER(PSBSOLA(X))
if X=""
QUIT
SET PSBFDA(53.687,I_","_PSBIENS,.01)=X
SET ^PSB(53.68,+PSBIENS,.7,I,0)=0
End DoDot:1
+40 IF $GET(PSBUID)=""
IF $GET(PSBDRUG)=""
Begin DoDot:1
+41 DO PSJ1^PSBVT(PSBDFN,PSBON)
+42 ;p132
IF $DATA(PSBADA)
SET X=""
FOR I=1:1
SET X=$ORDER(PSBADA(X))
if X=""
QUIT
SET PSBFDA(53.686,I_","_PSBIENS,.01)=$PIECE(PSBADA(X),U,2)
SET ^PSB(53.68,+PSBIENS,.6,I,0)=0
+43 ;p132
IF $DATA(PSBSOLA)
SET X=""
FOR I=1:1
SET X=$ORDER(PSBSOLA(X))
if X=""
QUIT
SET PSBFDA(53.687,I_","_PSBIENS,.01)=$PIECE(PSBSOLA(X),U,2)
SET ^PSB(53.68,+PSBIENS,.7,I,0)=0
End DoDot:1
+44 DO FILE^DIE("","PSBFDA","PSBMSG")
+45 ; PSB83*23
LOCK -^PSB(53.68,+PSBIENS)
+46 DO SUBMIT(+PSBIENS)
+47 SET RESULTS(0)="1^Missing Dose Submitted^"_+PSBIENS
+48 DO CLEAN^PSBVT
+49 QUIT
+50 ;
XQ ; Called via Kernel Menus
+1 NEW PSBMD,PSBSAVE,DA,DIK,DR,DDSFILE,XMY,XMTEXT,XMSUB
+2 DO NEW(.PSBMD)
+3 IF +PSBMD(0)<1
WRITE !,"Error: ",$PIECE(PSBMD(0),U,2)
SET DIR(0)="E"
DO ^DIR
QUIT
+4 SET DA=+PSBMD(0)
SET DR="[PSB MISSING DOSE REQUEST]"
SET DDSFILE=53.68
DO ^DDS
+5 WRITE @IOF
+6 IF 'PSBSAVE
WRITE !,"Cancelling Request..."
SET DIK="^PSB(53.68,"
DO ^DIK
WRITE "Cancelled!"
+7 if PSBSAVE
DO SUBMIT(DA)
+8 QUIT
+9 ;
SUBMIT(DA) ; Submit Request to Pharmacy
+1 NEW PSBWRD,PSBMG,PSBPRT,CLIEN
+2 SET PSBWRD=$PIECE(^PSB(53.68,DA,.1),U,2)
+3 SET PSBWRD=+$GET(^DIC(42,+PSBWRD,44))
+4 IF PSBCLIN]""
SET CLIEN=+$ORDER(^PS(53.46,"B",PSBCLNIEN,""))
+5 ;
+6 ; Get Mail Group
+7 ;
+8 SET PSBMG=$$GET^XPAR(PSBWRD_";SC(","PSB MG MISSING DOSE",,"E")
+9 if PSBMG=""
SET PSBMG=$$GET^XPAR("DIV","PSB MG MISSING DOSE",,"E")
+10 ; Add MG to notification
SET $PIECE(^PSB(53.68,DA,0),U,5)=PSBMG
+11 ;
+12 ; Get Printer - If NO printer can be found, then DO NOT print!!
+13 ;*70 - get CO printer if Clinic orders, else IM med & get IM printer
+14 ; IM printer uses Variable PSB PRINTER MISSING DOSE
+15 ; CO printer can come from 3 sources:
+16 ; 1st from Clinic Defintion file for the specific Clinic if defined
+17 ; 2nd from the Variable PSB PRINTER CO MISSING DOSE if defined
+18 ; 3rd just use the IM med printer Variable.
+19 ;
+20 ;*70
if PSBCLIN]""
Begin DoDot:1
+21 SET PSBPRT=$$GET1^DIQ(53.46,CLIEN,4)
+22 if PSBPRT=""
SET PSBPRT=$$GET^XPAR("DIV","PSB PRINTER CO MISSING DOSE",,"E")
+23 if PSBPRT=""
SET PSBPRT=$$GET^XPAR("DIV","PSB PRINTER MISSING DOSE",,"E")
End DoDot:1
+24 ;*70
if PSBCLIN=""
Begin DoDot:1
+25 SET PSBPRT=$$GET^XPAR(PSBWRD_";SC(","PSB PRINTER MISSING DOSE",,"E")
+26 if PSBPRT=""
SET PSBPRT=$$GET^XPAR("DIV","PSB PRINTER MISSING DOSE",,"E")
End DoDot:1
+27 ;
+28 ; Add MG to notification
SET $PIECE(^PSB(53.68,DA,0),U,6)=PSBPRT
+29 ;
+30 ; Send the report to the specified printer
+31 ;
+32 if PSBPRT]""
Begin DoDot:1
+33 WRITE !,"Submitting Request To Pharmacy on device ",PSBPRT,"..."
+34 DO NOW^%DTC
+35 SET ZTIO=PSBPRT
+36 SET ZTDTH=%
+37 SET ZTDESC="BCMA - MISSING DOSE REQUEST"
+38 SET ZTRTN="DQ^PSBMD("_DA_")"
+39 DO ^%ZTLOAD
+40 WRITE "Done!"
End DoDot:1
+41 ;
+42 ; Send the same stuff to the mail group
+43 ;
+44 if PSBMG]""
Begin DoDot:1
+45 WRITE !,"Notifying Pharmacy via Mail Group ",PSBMG,"..."
+46 DO HFSOPEN^PSBUTL("MISSING DOSE")
+47 USE IO
DO DQ(DA,1)
+48 DO HFSCLOSE^PSBUTL("MISSING DOSE")
+49 SET XMY("G."_PSBMG)=""
SET XMTEXT="^TMP(""PSBO"",$J,"
+50 SET XMSUB="BCMA - Missing Dose Request"
+51 DO ^XMD
+52 WRITE "Done!"
End DoDot:1
+53 QUIT
+54 ;
DQ(PSBMD,PSBMM) ; Dequeue report from Taskman
+1 NEW PSBFLD,PSBRET,DDIEN
+2 if '$DATA(^PSB(53.68,PSBMD,0))
QUIT
+3 ; PSB*3*23
LOCK +^PSB(53.68,PSBMD):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+4 SET PSBCFLD=$PIECE(^PSB(53.68,PSBMD,.1),U,3)
+5 ; PSB*3*23
LOCK -^PSB(53.68,PSBMD)
+6 ; It is not a mail message
if '$GET(PSBMM)
Begin DoDot:1
+7 WRITE !,$TRANSLATE($JUSTIFY("",75)," ","=")
+8 WRITE !,"Report: MISSING DOSE REQUEST"
+9 WRITE !,"Date Created: "
DO NOW^%DTC
SET Y=%
DO D^DIQ
WRITE Y
+10 WRITE !,$TRANSLATE($JUSTIFY("",75)," ","="),!
End DoDot:1
+11 ;I $G(PSBCFLD)'="" F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.13,.14,.19,.15,.16,.17 D OUT ;*70
+12 ;I $G(PSBCFLD)="" F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.25,.15,.19,.16,.17 D OUT ;*70
+13 ;I $D(^PSB(53.68,PSBMD,.6)) S X=0 F S X=$O(^PSB(53.68,PSBMD,.6,X)) Q:'X W !?3,"ADDITIVE: ",$$GET1^DIQ(52.6,+^PSB(53.68,PSBMD,.6,X,0),.01)
+14 ;I $D(^PSB(53.68,PSBMD,.7)) S X=0 F S X=$O(^PSB(53.68,PSBMD,.7,X)) Q:'X W !?3,"SOLUTION: ",$$GET1^DIQ(52.7,+^PSB(53.68,PSBMD,.7,X,0),.01)
+15 ;*106 - added HAZ notifications for dispensed drugs
IF $GET(PSBCFLD)'=""
Begin DoDot:1
+16 FOR PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.13
DO OUT
+17 SET DDIEN=$$GET1^DIQ(53.68,PSBMD,.13,"I")
DO HAZOUT(DDIEN,31)
+18 ;*70
FOR PSBFLD=.14,.19,.15,.16,.17
DO OUT
End DoDot:1
+19 ;*70
IF $GET(PSBCFLD)=""
FOR PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.25,.15,.19,.16,.17
DO OUT
+20 ;*106 - added HAZ notifications for additives
IF $DATA(^PSB(53.68,PSBMD,.6))
SET X=0
Begin DoDot:1
+21 FOR
SET X=$ORDER(^PSB(53.68,PSBMD,.6,X))
if 'X
QUIT
WRITE !?3,"ADDITIVE: ",$$GET1^DIQ(52.6,+^PSB(53.68,PSBMD,.6,X,0),.01)
Begin DoDot:2
+22 SET DDIEN=$$GET1^DIQ(52.6,+^PSB(53.68,PSBMD,.6,X,0),1,"I")
DO HAZOUT(DDIEN,14)
End DoDot:2
End DoDot:1
+23 ;*106 - added HAZ notifications for solutions
IF $DATA(^PSB(53.68,PSBMD,.7))
SET X=0
Begin DoDot:1
+24 FOR
SET X=$ORDER(^PSB(53.68,PSBMD,.7,X))
if 'X
QUIT
WRITE !?3,"SOLUTION: ",$$GET1^DIQ(52.7,+^PSB(53.68,PSBMD,.7,X,0),.01)
Begin DoDot:2
+25 SET DDIEN=$$GET1^DIQ(52.7,+^PSB(53.68,PSBMD,.7,X,0),1,"I")
DO HAZOUT(DDIEN,14)
End DoDot:2
End DoDot:1
+26 QUIT
OUT ;
+1 DO FIELD^DID(53.68,PSBFLD,"","LABEL","PSBRET")
+2 WRITE !?3,PSBRET("LABEL"),":"
FOR
if $X>30
QUIT
WRITE "."
+3 WRITE $$GET1^DIQ(53.68,PSBMD_",",PSBFLD)
+4 IF PSBFLD=.11
Begin DoDot:1
+5 NEW DFN,VA,VADM
SET DFN=$$GET1^DIQ(53.68,PSBMD_",",.11,"I")
DO DEM^VADPT
+6 WRITE !?3,$$GET^XPAR("ALL","PSB PATIENT ID LABEL")
+7 IF $GET(DUZ("AG"))="I"
Begin DoDot:2
+8 WRITE ":"
FOR
if $X>30
QUIT
WRITE "."
End DoDot:2
+9 IF '$TEST
Begin DoDot:2
+10 WRITE " (LAST 4 NUMBERS):"
FOR
if $X>30
QUIT
WRITE "."
End DoDot:2
+11 WRITE VA("BID")
End DoDot:1
+12 if PSBFLD=.13
WRITE " ("_$PIECE($GET(^PSB(53.68,PSBMD,.1)),U,3)_")"
+13 SET ZTREQ="@"
+14 QUIT
+15 ;
HAZOUT(P50,POS) ; Write warnings for drugs, additives and solutions that are Hazardous to Handle or Dispose *106
+1 NEW PSBHAZ
+2 SET PSBHAZ=$$HAZ^PSSUTIL(P50)
+3 IF $PIECE(PSBHAZ,U)!$PIECE(PSBHAZ,U,2)
WRITE !?POS
if $PIECE(PSBHAZ,U)
WRITE "<<HAZ Handle>> "
if $PIECE(PSBHAZ,U,2)
WRITE "<<HAZ Dispose>>"
+4 QUIT
+5 ;
NEW(RESULTS) ; Create a new missing dose request
+1 ; Called interactively and via RPCBroker
+2 NEW DIC
+3 KILL RESULTS
+4 IF '+$GET(DUZ)
SET RESULTS(0)="-1^Undefined User"
QUIT
+5 IF '$GET(DUZ(2))
SET RESULTS(0)="-1^Undefined Division"
QUIT
+6 ; Lock Log
+7 LOCK +^PSB(53.68,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+8 IF '$TEST
SET RESULTS(0)="-1^Request Log Locked"
QUIT
+9 ; Generate Unique Entry and Create
+10 FOR
DO NOW^%DTC
SET X=$EXTRACT(%_"000000",1,14)
SET X=(1700+$EXTRACT(X,1,3))_$EXTRACT(X,4,14)
SET X="MD-"_$TRANSLATE(X,".","-")
if '$DATA(^PSB(53.68,"B",X))
QUIT
+11 SET DIC="^PSB(53.68,"
SET DIC(0)="L"
+12 SET DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.07///1"
+13 ;VRN
KILL D0
+14 DO FILE^DICN
+15 LOCK -^PSB(53.68,0)
+16 ; Okay, setup return and Boogie
+17 IF +Y<1
SET RESULTS(0)="-1^Error Creating Request"
+18 IF '$TEST
SET RESULTS(0)=Y
+19 QUIT
+20 ;
VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
+1 NEW PSB,PSBFLD,PSBMSG
+2 FOR PSB=1:1
if $PIECE(PSBFLDS,";",PSB)=""
QUIT
SET PSBFLD=$PIECE(PSBFLDS,";",PSB)
SET PSBFLD(PSBFLD)=$$GET^DDSVAL(53.68,DA,PSBFLD)
+3 IF $DATA(PSBFLD(.21))
if PSBFLD(.21)="N"
KILL PSBFLD(.22),PSBFLD(.23)
+4 SET PSB=""
FOR
SET PSB=$ORDER(PSBFLD(PSB))
if PSB=""
QUIT
if PSBFLD(PSB)=""
Begin DoDot:1
+5 IF '$DATA(PSBMSG)
SET PSBMSG(0)="UNABLE TO FILE REQUEST"
SET PSBMSG(1)=" "
SET PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED"
+6 DO FIELD^DID(53.68,PSB,"","TITLE;LABEL","PSB")
+7 SET X=" Missing Field: "_$SELECT(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
SET PSBMSG($ORDER(PSBMSG(""),-1)+1)=X
End DoDot:1
+8 ; All is well
if '$DATA(PSBMSG)
QUIT
+9 DO MSG^DDSUTL(.PSBMSG)
+10 SET DDSERROR=1
+11 QUIT
+12 ;
CHK1 ; Start PSB*3*100 changes: use 'DIVAS' cross ref for multidivision sites
+1 ; DUZ(2), the user's division, is set at sign-on. At multidivision sites where a user has access
+2 ; to multiple divisions, allow selection of a division from the divisions defined in file #40.8.
+3 ; The user must have at least one division from file #40.8 in his file #200 record.
+4 KILL ^TMP("PSBMD",$JOB)
+5 NEW DIR
+6 WRITE !
+7 SET DIR(0)="SB^A:All Divisions;O:One Division"
+8 SET DIR("?")="Select either All Divisions or One Division."
+9 SET DIR("A")="Do you want (A)ll Divisions or just (O)ne Division"
+10 SET DIR("B")="O"
+11 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)!$DATA(DIRUT)
QUIT
+12 IF Y=""
QUIT
+13 ; regardless user divisions in file #200
IF Y(0)="One Division"
DO ONE
QUIT
+14 IF Y(0)="All Divisions"
DO ALL
QUIT
+15 QUIT
+16 ;
ALL ; user gets all divisions (current behavior); applicable to single division sites as well
+1 SET Y(0)="All Divisions"
+2 SET PSBDIV=DUZ(2)
+3 ; current IEN for station
SET PSBSTIEN=+$ORDER(^DG(40.8,"AD",DUZ(2),""))
+4 SET Y=$$GET1^DIQ(40.8,PSBSTIEN,.01,"E")
+5 IF '$DATA(Y)
SET Y=DUZ(2)
+6 SET PSBNAME=$$NAME^XUAF4(DUZ(2))
+7 SET PSBMUDV=0
+8 SET ^TMP("PSBMD",$JOB)=PSBMUDV_U_PSBDIV_U_PSBNAME
+9 QUIT
+10 ;
ONE ; when user selects one division from many in file #200, look at file #40.8 for a match if available
+1 WRITE !
+2 ; current IEN for station
SET PSBSTIEN=+$ORDER(^DG(40.8,"AD",DUZ(2),""))
+3 ;division name
SET PSBDVNM=$$GET1^DIQ(40.8,PSBSTIEN,.01,"I")
+4 SET DIC("B")=PSBDVNM
+5 SET DIC("A")="Select Division: "
SET DIC="^DG(40.8,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $$SITE^VASITE(,+Y)>0"
+6 DO ^DIC
+7 ; capture the division name and number after user selection
+8 SET PSBNAME=$$GET1^DIQ(40.8,+Y,.01,"E")
+9 ; pointer to file #4
SET PSBDPTR=$$GET1^DIQ(40.8,+Y,.07,"I")
+10 SET PSBDIV=PSBDPTR
+11 SET ^TMP("PSBMD",$JOB)=PSBMUDV_U_PSBDIV_U_PSBNAME
+12 QUIT
+13 ;end of changes for PSB*3*100
+14 ;
FLWUP ; Follow-Up on missing dose
+1 ; start PSB*3*100 changes
+2 NEW D0,DIC,PSBDATA,PSBDPTR,PSBDIV,PSBDVNM,PSBNAME,PSBMUDV,PSBSTIEN,X,Y
+3 SET D0=1
SET PSBMUDV=$SELECT($$GET1^DIQ(43,D0,11,"I")=1:1,1:0)
+4 IF $PIECE($GET(^VA(200,DUZ,2,0)),U,4)=0
WRITE !!,$CHAR(7),"You have no valid divisions in the NEW PERSON file."
SET Y="^"
QUIT
+5 IF '$ORDER(^DG(40.8,"AD",DUZ(2),""))
WRITE !!,$CHAR(7),"Your NEW PERSON file division was not found in the MEDICAL CENTER DIVISION file."
SET Y="^"
QUIT
+6 IF PSBMUDV=1
DO CHK1
+7 IF PSBMUDV=0
DO ALL
+8 IF Y=""!(Y<0)!(Y="^")
QUIT
+9 SET PSBDIV=$PIECE($GET(^TMP("PSBMD",$JOB)),U,2)
+10 SET PSBNAME=$PIECE($GET(^TMP("PSBMD",$JOB)),U,3)
+11 ; end of changes for PSB*3*100
+12 ;*70
NEW DIR,PSBIEN,PSBX,DA,DR,DDSFILE,PSBHDR,PSBDRUG,LOC
+13 ;*106
NEW PSBHAZ,DDIEN
+14 SET Y=""
FOR
if Y="^"
QUIT
Begin DoDot:1
+15 KILL ^TMP("PSB",$JOB)
SET X=""
+16 ;start PSB*3*100 changes: user did not select one division and will see all the records (single station functionality)
+17 IF $GET(PSBMUDV)=0
Begin DoDot:2
+18 FOR
SET X=$ORDER(^PSB(53.68,"AS",1,X),-1)
if 'X
QUIT
SET Y=$ORDER(^TMP("PSB",$JOB,""),-1)+1
SET ^TMP("PSB",$JOB,Y)=X
SET ^TMP("PSB",$JOB,0)=Y
End DoDot:2
+19 ;
+20 ; user selected one division
+21 IF $GET(PSBMUDV)=1
Begin DoDot:2
+22 FOR
SET X=$ORDER(^PSB(53.68,"DIVAS",1,PSBDIV,X),-1)
if 'X
QUIT
SET Y=$ORDER(^TMP("PSB",$JOB,""),-1)+1
SET ^TMP("PSB",$JOB,Y)=X
SET ^TMP("PSB",$JOB,0)=Y
End DoDot:2
+23 ;
+24 IF '$ORDER(^TMP("PSB",$JOB,0))
WRITE !!,"No Unresolved Missing Dose Requests Found."
SET Y="^"
QUIT
+25 IF $GET(PSBMUDV)=0
SET PSBHDR="Currently Unresolved Missing Dose Requests"
+26 IF $GET(PSBMUDV)=1
SET PSBHDR="Currently Unresolved Missing Dose Requests for: "_PSBNAME
+27 ;end of changes for PSB*3*100
+28 WRITE @IOF,PSBHDR,!,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+29 FOR PSBX=0:0
SET PSBX=$ORDER(^TMP("PSB",$JOB,PSBX))
if 'PSBX!(Y="^")
QUIT
SET PSBIEN=^(PSBX)_","
Begin DoDot:2
+30 WRITE !,$JUSTIFY(PSBX,2),". ",$$GET1^DIQ(53.68,PSBIEN,.01)
+31 WRITE ?25,$$GET1^DIQ(53.68,PSBIEN,.11)
+32 ; get correct location ;*70
+33 SET LOC=$SELECT($$GET1^DIQ(53.68,PSBIEN,1)]"":$$GET1^DIQ(53.68,PSBIEN,1),1:$$GET1^DIQ(53.68,PSBIEN,.12))
+34 ;*70
WRITE ?57,LOC
+35 ;*106
SET PSBDRUG=$$GET1^DIQ(53.68,PSBIEN,.13)
SET DDIEN=$$GET1^DIQ(53.68,PSBIEN,.13,"I")
+36 ;*106
IF PSBDRUG]""
SET PSBHAZ=$$HAZ^PSSUTIL(DDIEN)
WRITE !?5,PSBDRUG
IF $PIECE(PSBHAZ,U)!$PIECE(PSBHAZ,U,2)
WRITE !?5
if $PIECE(PSBHAZ,U)
WRITE "<<HAZ Handle>> "
if $PIECE(PSBHAZ,U,2)
WRITE "<<HAZ Dispose>>"
+37 IF PSBDRUG=""
Begin DoDot:3
+38 WRITE !?5,"UNIQUE ID: ",$$GET1^DIQ(53.68,PSBIEN,.25)
+39 SET X=0
FOR
SET X=$ORDER(^PSB(53.68,+PSBIEN,.6,X))
if 'X
QUIT
WRITE !?10,"ADDITIVES: ",$$GET1^DIQ(52.6,+^PSB(53.68,+PSBIEN,.6,X,0),.01)
+40 SET X=0
FOR
SET X=$ORDER(^PSB(53.68,+PSBIEN,.7,X))
if 'X
QUIT
WRITE !?10,"SOLUTIONS: ",$$GET1^DIQ(52.7,+^PSB(53.68,+PSBIEN,.7,X,0),.01)
End DoDot:3
+41 ;use -5 so if Haz added line displayed, as 3rd line, then needs to not scroll line 1 HDR off screen in some cases *106
if $Y>(IOSL-5)
SET Y=$$PAGE(PSBX)
End DoDot:2
+42 if Y'="^"
SET Y=$$PAGE(PSBX)
End DoDot:1
+43 ; PSB*3*100
KILL ^TMP("PSB",$JOB),^TMP("PSBMD",$JOB)
+44 QUIT
+45 ;
PAGE(PSBIX) ;
+1 ;
+2 NEW X,X1,PSBCX,PSBDX
+3 SET DIR("A")="Select Missing Dose Request # (<RET> to continue, '^' to quit)"
+4 IF PSBIX=""
SET DIR("A")="Select Missing Dose Request # (<RET> or '^' to quit)"
+5 SET DIR(0)="NO^1:"_$SELECT(PSBIX="":$ORDER(^TMP("PSB",$JOB,PSBX),-1),1:PSBIX)_":0"
+6 DO ^DIR
SET PSBDX=+Y
+7 IF PSBIX=""
IF Y=""
SET Y="^"
QUIT Y
+8 IF $GET(DTOUT)
SET Y="^"
QUIT Y
+9 IF Y="^"
QUIT Y
+10 IF Y=""
WRITE @IOF,PSBHDR,!,$TRANSLATE($JUSTIFY("",IOM)," ","-")
QUIT Y
+11 SET (DA,PSBCX)=^TMP("PSB",$JOB,+Y)
SET DR="[PSB MISSING DOSE FOLLOWUP]"
SET DDSFILE=53.68
+12 Begin DoDot:1
+13 DO ^DDS
+14 ; start changes for PSB*3*100
+15 IF $GET(PSBMUDV)=0
IF $DATA(^PSB(53.68,"AS",0,PSBCX))
KILL ^TMP("PSB",$JOB)
SET X=""
FOR
SET X=$ORDER(^PSB(53.68,"AS",1,X),-1)
if 'X
QUIT
SET X1=$ORDER(^TMP("PSB",$JOB,""),-1)+1
SET ^TMP("PSB",$JOB,X1)=X
SET ^TMP("PSB",$JOB,0)=X1
+16 IF $GET(PSBMUDV)=1
IF $DATA(^PSB(53.68,"DIVAS",0,PSBDIV))
KILL ^TMP("PSB",$JOB)
SET X=""
FOR
SET X=$ORDER(^PSB(53.68,"DIVAS",1,PSBDIV,X),-1)
if 'X
QUIT
SET X1=$ORDER(^TMP("PSB",$JOB,""),-1)+1
SET ^TMP("PSB",$JOB,X1)=X
SET ^TMP("PSB",$JOB,0)=X1
+17 ; stop printing header twice (old bug) by checking PSBX before setting it to zero.
+18 IF PSBX>0
SET PSBX=0
WRITE @IOF,PSBHDR,!,$TRANSLATE($JUSTIFY("",IOM)," ","-")
End DoDot:1
QUIT Y
+19 ; end of changes for PSB*3*100
+20 ;
POST ;call from 'Patient' field of screenman form PSB MISSING DOSE REQUEST
+1 ;
+2 NEW DFN
+3 SET DFN=X
DO IN5^VADPT
+4 ; value of DIE is 53.68, BCMA MISSING DOSE REQUEST FILE called from ScreenMan
DO PUT^DDSVAL(DIE,.DA,.12,$PIECE(VAIP(5),U,2))
+5 ; value of DIE is 53.68, BCMA MISSING DOSE REQUEST FILE called from ScreenMan
DO PUT^DDSVAL(DIE,.DA,.18,$PIECE(VAIP(6),U,1),"","I")
+6 DO REFRESH^DDSUTL
+7 QUIT
