- PSBMD ;BIRMINGHAM/EFC - BCMA MISSING DOSE FUNCTIONS ;6/28/10 1:37pm
- ;;3.0;BAR CODE MED ADMIN;**23,42**;Mar 2004;Build 23
- ;
- ; Reference/IA
- ; ^DIC(42/10039
- ; ^DPT(/10035
- ; IN5^VADPT/10061
- ; DEM^VADPT/10061
- ; ^XMB/10070
- ; 52.6/436
- ; 52.7/437
- ;
- RPC(RESULTS,PSBDFN,PSBDRUG,PSBDOSE,PSBRSN,PSBADMIN,PSBNEED,PSBUID,PSBON,PSBSCHD) ;
- ;
- ; RPC: PSB SUBMIT MISSING DOSE
- ;
- ; Description:
- ; Allows the client to submit a missing dose interactively
- ;
- N DFN,PSBNOW,PSBFDA,PSBIENS,PSBMD,PSBMSG
- 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
- 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 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
- S DFN=PSBDFN D IN5^VADPT S PSBFDA(53.68,PSBIENS,.18)=$P(VAIP(6),U,1)
- 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)=I
- .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)=I
- 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)=X
- .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)=X
- 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
- S PSBWRD=$P(^PSB(53.68,DA,.1),U,2)
- S PSBWRD=+$G(^DIC(42,+PSBWRD,44))
- ;
- ; 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
- ;
- 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
- 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,.13,.14,.19,.15,.16,.17 D OUT
- I $G(PSBCFLD)="" F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,.25,.15,.19,.16,.17 D OUT
- 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)
- 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
- ;
- 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
- ;
- FLWUP ; Follow-Up on missing dose
- N DIR,PSBIEN,PSBX,DA,DR,DDSFILE,PSBHDR,PSBDRUG
- S Y="" F Q:Y="^" D
- .K ^TMP("PSB",$J) S X=""
- .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
- .I '$O(^TMP("PSB",$J,0)) W !!,"No Unresolved Missing Dose Requests Found." S Y="^" Q
- .S PSBHDR="Currently Unresolved Missing Dose Requests"
- .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)
- ..W ?57,$$GET1^DIQ(53.68,PSBIEN,.12)
- ..S PSBDRUG=$$GET1^DIQ(53.68,PSBIEN,.13)
- ..I PSBDRUG]"" W !?5,PSBDRUG
- ..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-4) Y=$$PAGE(PSBX)
- .S:Y'="^" Y=$$PAGE(PSBX)
- 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
- .I $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
- .S PSBX=0 W @IOF,PSBHDR,!,$TR($J("",IOM)," ","-")
- ;
- 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
- PSBMD ;BIRMINGHAM/EFC - BCMA MISSING DOSE FUNCTIONS ;6/28/10 1:37pm
- +1 ;;3.0;BAR CODE MED ADMIN;**23,42**;Mar 2004;Build 23
- +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 ;
- RPC(RESULTS,PSBDFN,PSBDRUG,PSBDOSE,PSBRSN,PSBADMIN,PSBNEED,PSBUID,PSBON,PSBSCHD) ;
- +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 DO NEW(.PSBMD)
- +9 IF +PSBMD(0)<1
- SET RESULTS(0)="-1^Unable to create missing dose request"
- QUIT
- +10 SET PSBIENS=+PSBMD(0)_","
- +11 DO NOW^%DTC
- SET PSBNOW=%
- +12 SET PSBFDA(53.68,PSBIENS,.02)=PSBNOW
- +13 SET PSBFDA(53.68,PSBIENS,.03)=DUZ
- +14 SET PSBFDA(53.68,PSBIENS,.04)=DUZ(2)
- +15 SET PSBFDA(53.68,PSBIENS,.11)=PSBDFN
- +16 SET X=$GET(^DPT(PSBDFN,.1))
- IF X]""
- SET X=$ORDER(^DIC(42,"B",X,0))
- IF X
- SET PSBFDA(53.68,PSBIENS,.12)=X
- +17 SET PSBFDA(53.68,PSBIENS,.13)=PSBDRUG
- +18 SET PSBFDA(53.68,PSBIENS,.14)=PSBDOSE
- +19 SET PSBFDA(53.68,PSBIENS,.15)=PSBRSN
- +20 SET PSBFDA(53.68,PSBIENS,.16)=PSBADMIN
- +21 SET PSBFDA(53.68,PSBIENS,.17)=PSBNEED
- +22 SET PSBFDA(53.68,PSBIENS,.19)=PSBSCHD
- +23 SET PSBFDA(53.68,PSBIENS,.25)=PSBUID
- +24 SET DFN=PSBDFN
- DO IN5^VADPT
- SET PSBFDA(53.68,PSBIENS,.18)=$PIECE(VAIP(6),U,1)
- +25 DO FILE^DIE("","PSBFDA","PSBMSG")
- +26 ; PSB*3*23
- LOCK +^PSB(53.68,+PSBIENS):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- +27 IF $GET(PSBUID)'=""
- Begin DoDot:1
- +28 DO PSJ1^PSBVT(PSBDFN,PSBON)
- KILL PSBADA,PSBSOLA
- +29 IF '$DATA(PSBUIDA(PSBUID))
- FOR
- DO PSJ1^PSBVT(PSBDFN,PSBPONX)
- KILL PSBADA,PSBSOLA
- IF $DATA(PSBUIDA(PSBUID))
- QUIT
- IF PSBPONX=""
- QUIT
- +30 FOR I=1:1
- SET PSBAD=$PIECE(PSBUIDA(PSBUID),U,I)
- IF PSBAD=""
- QUIT
- IF PSBAD["ADD"
- SET PSBADA($PIECE(PSBAD,";",2))=""
- +31 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)=I
- +32 FOR I=1:1
- SET PSBSOL=$PIECE(PSBUIDA(PSBUID),U,I)
- IF PSBSOL=""
- QUIT
- IF PSBSOL["SOL"
- SET PSBSOLA($PIECE(PSBSOL,";",2))=""
- +33 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)=I
- End DoDot:1
- +34 IF $GET(PSBUID)=""
- IF $GET(PSBDRUG)=""
- Begin DoDot:1
- +35 DO PSJ1^PSBVT(PSBDFN,PSBON)
- +36 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)=X
- +37 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)=X
- End DoDot:1
- +38 DO FILE^DIE("","PSBFDA","PSBMSG")
- +39 ; PSB83*23
- LOCK -^PSB(53.68,+PSBIENS)
- +40 DO SUBMIT(+PSBIENS)
- +41 SET RESULTS(0)="1^Missing Dose Submitted^"_+PSBIENS
- +42 DO CLEAN^PSBVT
- +43 QUIT
- +44 ;
- 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
- +2 SET PSBWRD=$PIECE(^PSB(53.68,DA,.1),U,2)
- +3 SET PSBWRD=+$GET(^DIC(42,+PSBWRD,44))
- +4 ;
- +5 ; Get Mail Group
- +6 ;
- +7 SET PSBMG=$$GET^XPAR(PSBWRD_";SC(","PSB MG MISSING DOSE",,"E")
- +8 IF PSBMG=""
- SET PSBMG=$$GET^XPAR("DIV","PSB MG MISSING DOSE",,"E")
- +9 ; Add MG to notification
- SET $PIECE(^PSB(53.68,DA,0),U,5)=PSBMG
- +10 ;
- +11 ; Get Printer
- +12 ;
- +13 SET PSBPRT=$$GET^XPAR(PSBWRD_";SC(","PSB PRINTER MISSING DOSE",,"E")
- +14 IF PSBPRT=""
- SET PSBPRT=$$GET^XPAR("DIV","PSB PRINTER MISSING DOSE",,"E")
- +15 ; Add MG to notification
- SET $PIECE(^PSB(53.68,DA,0),U,6)=PSBPRT
- +16 ;
- +17 ; Send the report to the specified printer
- +18 ;
- +19 IF PSBPRT]""
- Begin DoDot:1
- +20 WRITE !,"Submitting Request To Pharmacy on device ",PSBPRT,"..."
- +21 DO NOW^%DTC
- +22 SET ZTIO=PSBPRT
- +23 SET ZTDTH=%
- +24 SET ZTDESC="BCMA - MISSING DOSE REQUEST"
- +25 SET ZTRTN="DQ^PSBMD("_DA_")"
- +26 DO ^%ZTLOAD
- +27 WRITE "Done!"
- End DoDot:1
- +28 ;
- +29 ; Send the same stuff to the mail group
- +30 ;
- +31 IF PSBMG]""
- Begin DoDot:1
- +32 WRITE !,"Notifying Pharmacy via Mail Group ",PSBMG,"..."
- +33 DO HFSOPEN^PSBUTL("MISSING DOSE")
- +34 USE IO
- DO DQ(DA,1)
- +35 DO HFSCLOSE^PSBUTL("MISSING DOSE")
- +36 SET XMY("G."_PSBMG)=""
- SET XMTEXT="^TMP(""PSBO"",$J,"
- +37 SET XMSUB="BCMA - Missing Dose Request"
- +38 DO ^XMD
- +39 WRITE "Done!"
- End DoDot:1
- +40 QUIT
- +41 ;
- DQ(PSBMD,PSBMM) ; Dequeue report from Taskman
- +1 NEW PSBFLD,PSBRET
- +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 IF $GET(PSBCFLD)'=""
- FOR PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,.13,.14,.19,.15,.16,.17
- DO OUT
- +12 IF $GET(PSBCFLD)=""
- FOR PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,.25,.15,.19,.16,.17
- DO OUT
- +13 IF $DATA(^PSB(53.68,PSBMD,.6))
- SET X=0
- 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)
- +14 IF $DATA(^PSB(53.68,PSBMD,.7))
- SET X=0
- 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)
- +15 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 ;
- 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 ;
- FLWUP ; Follow-Up on missing dose
- +1 NEW DIR,PSBIEN,PSBX,DA,DR,DDSFILE,PSBHDR,PSBDRUG
- +2 SET Y=""
- FOR
- IF Y="^"
- QUIT
- Begin DoDot:1
- +3 KILL ^TMP("PSB",$JOB)
- SET X=""
- +4 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
- +5 IF '$ORDER(^TMP("PSB",$JOB,0))
- WRITE !!,"No Unresolved Missing Dose Requests Found."
- SET Y="^"
- QUIT
- +6 SET PSBHDR="Currently Unresolved Missing Dose Requests"
- +7 WRITE @IOF,PSBHDR,!,$TRANSLATE($JUSTIFY("",IOM)," ","-")
- +8 FOR PSBX=0:0
- SET PSBX=$ORDER(^TMP("PSB",$JOB,PSBX))
- IF 'PSBX!(Y="^")
- QUIT
- SET PSBIEN=^(PSBX)_","
- Begin DoDot:2
- +9 WRITE !,$JUSTIFY(PSBX,2),". ",$$GET1^DIQ(53.68,PSBIEN,.01)
- +10 WRITE ?25,$$GET1^DIQ(53.68,PSBIEN,.11)
- +11 WRITE ?57,$$GET1^DIQ(53.68,PSBIEN,.12)
- +12 SET PSBDRUG=$$GET1^DIQ(53.68,PSBIEN,.13)
- +13 IF PSBDRUG]""
- WRITE !?5,PSBDRUG
- +14 IF PSBDRUG=""
- Begin DoDot:3
- +15 WRITE !?5,"UNIQUE ID: ",$$GET1^DIQ(53.68,PSBIEN,.25)
- +16 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)
- +17 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
- +18 IF $Y>(IOSL-4)
- SET Y=$$PAGE(PSBX)
- End DoDot:2
- +19 IF Y'="^"
- SET Y=$$PAGE(PSBX)
- End DoDot:1
- +20 QUIT
- 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 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
- +15 SET PSBX=0
- WRITE @IOF,PSBHDR,!,$TRANSLATE($JUSTIFY("",IOM)," ","-")
- End DoDot:1
- QUIT Y
- +16 ;
- 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