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

PSBMD.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; Reference/IA
  1.  ; ^DIC(42/10039
  1.  ; ^DPT(/10035
  1.  ; IN5^VADPT/10061
  1.  ; DEM^VADPT/10061
  1.  ; ^XMB/10070
  1.  ; 52.6/436
  1.  ; 52.7/437
  1.  ; ^DG(40.8/417
  1.  ; 4/2171
  1.  ; ^DG(40.8/2817
  1.  ; ^VA(200/10060
  1.  ; ^DIC(4/10090
  1.  ; ^DG(43/6812
  1.  ;
  1.  ;*70 -  add new kernel variable for CO Missing Dose Printer.
  1.  ;       use Clinc name if passed in for the new field Clinic or
  1.  ;        assume Ward and get ien.
  1.  ;*106-  add Hazardous Handle & Dispose flags
  1.  ;
  1. RPC(RESULTS,PSBDFN,PSBDRUG,PSBDOSE,PSBRSN,PSBADMIN,PSBNEED,PSBUID,PSBON,PSBSCHD,PSBCLIN,PSBCLNIEN) ;
  1.  ;
  1.  ; RPC: PSB SUBMIT MISSING DOSE
  1.  ;
  1.  ; Description:
  1.  ; Allows the client to submit a missing dose interactively
  1.  ;
  1.  N DFN,PSBNOW,PSBFDA,PSBIENS,PSBMD,PSBMSG
  1.  S PSBCLNIEN=+$G(PSBCLNIEN)    ;*70 insure numeric
  1.  D NEW(.PSBMD)
  1.  I +PSBMD(0)<1 S RESULTS(0)="-1^Unable to create missing dose request"  Q
  1.  S PSBIENS=+PSBMD(0)_","
  1.  D NOW^%DTC S PSBNOW=%
  1.  S PSBFDA(53.68,PSBIENS,.02)=PSBNOW
  1.  S PSBFDA(53.68,PSBIENS,.03)=DUZ
  1.  S PSBFDA(53.68,PSBIENS,.04)=DUZ(2)
  1.  S PSBFDA(53.68,PSBIENS,.11)=PSBDFN
  1.  ; Ward or Clinic - use Clinic name if passed, else get Ward ien.  *70
  1.  I PSBCLIN]"" D
  1.  .S PSBFDA(53.68,PSBIENS,1)=PSBCLNIEN
  1.  E  D
  1.  .S X=$G(^DPT(PSBDFN,.1))
  1.  .I X]"" S X=$O(^DIC(42,"B",X,0)) S:X PSBFDA(53.68,PSBIENS,.12)=X
  1.  .S DFN=PSBDFN D IN5^VADPT S PSBFDA(53.68,PSBIENS,.18)=$P(VAIP(6),U,1)
  1.  S PSBFDA(53.68,PSBIENS,.13)=PSBDRUG
  1.  S PSBFDA(53.68,PSBIENS,.14)=PSBDOSE
  1.  S PSBFDA(53.68,PSBIENS,.15)=PSBRSN
  1.  S PSBFDA(53.68,PSBIENS,.16)=PSBADMIN
  1.  S PSBFDA(53.68,PSBIENS,.17)=PSBNEED
  1.  S PSBFDA(53.68,PSBIENS,.19)=PSBSCHD
  1.  S PSBFDA(53.68,PSBIENS,.25)=PSBUID
  1.  D FILE^DIE("","PSBFDA","PSBMSG")
  1.  L +^PSB(53.68,+PSBIENS):$S($G(DILOCKTM)>0:DILOCKTM,1:3)  ; PSB*3*23
  1.  I $G(PSBUID)'="" D
  1.  .D PSJ1^PSBVT(PSBDFN,PSBON) K PSBADA,PSBSOLA
  1.  .I '$D(PSBUIDA(PSBUID)) F  D PSJ1^PSBVT(PSBDFN,PSBPONX) K PSBADA,PSBSOLA Q:$D(PSBUIDA(PSBUID))  Q:PSBPONX=""
  1.  .F I=1:1 S PSBAD=$P(PSBUIDA(PSBUID),U,I) Q:PSBAD=""  I PSBAD["ADD" S PSBADA($P(PSBAD,";",2))=""
  1.  .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
  1.  .F I=1:1 S PSBSOL=$P(PSBUIDA(PSBUID),U,I) Q:PSBSOL=""  I PSBSOL["SOL" S PSBSOLA($P(PSBSOL,";",2))=""
  1.  .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
  1.  I $G(PSBUID)="",$G(PSBDRUG)="" D
  1.  .D PSJ1^PSBVT(PSBDFN,PSBON)
  1.  .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
  1.  .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
  1.  D FILE^DIE("","PSBFDA","PSBMSG")
  1.  L -^PSB(53.68,+PSBIENS) ; PSB83*23
  1.  D SUBMIT(+PSBIENS)
  1.  S RESULTS(0)="1^Missing Dose Submitted^"_+PSBIENS
  1.  D CLEAN^PSBVT
  1.  Q
  1.  ;
  1. XQ ; Called via Kernel Menus
  1.  N PSBMD,PSBSAVE,DA,DIK,DR,DDSFILE,XMY,XMTEXT,XMSUB
  1.  D NEW(.PSBMD)
  1.  I +PSBMD(0)<1 W !,"Error: ",$P(PSBMD(0),U,2) S DIR(0)="E" D ^DIR Q
  1.  S DA=+PSBMD(0),DR="[PSB MISSING DOSE REQUEST]",DDSFILE=53.68 D ^DDS
  1.  W @IOF
  1.  I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.68," D ^DIK W "Cancelled!"
  1.  D:PSBSAVE SUBMIT(DA)
  1.  Q
  1.  ;
  1. SUBMIT(DA) ; Submit Request to Pharmacy
  1.  N PSBWRD,PSBMG,PSBPRT,CLIEN
  1.  S PSBWRD=$P(^PSB(53.68,DA,.1),U,2)
  1.  S PSBWRD=+$G(^DIC(42,+PSBWRD,44))
  1.  I PSBCLIN]"" S CLIEN=+$O(^PS(53.46,"B",PSBCLNIEN,""))
  1.  ;
  1.  ; Get Mail Group
  1.  ;
  1.  S PSBMG=$$GET^XPAR(PSBWRD_";SC(","PSB MG MISSING DOSE",,"E")
  1.  S:PSBMG="" PSBMG=$$GET^XPAR("DIV","PSB MG MISSING DOSE",,"E")
  1.  S $P(^PSB(53.68,DA,0),U,5)=PSBMG ; Add MG to notification
  1.  ;
  1.  ; Get Printer - If NO printer can be found, then DO NOT print!!
  1.  ;*70 - get CO printer if Clinic orders, else IM med & get IM printer
  1.  ; IM printer uses Variable PSB PRINTER MISSING DOSE
  1.  ; CO printer can come from 3 sources:
  1.  ;  1st from Clinic Defintion file for the specific Clinic if defined
  1.  ;  2nd from the Variable PSB PRINTER CO MISSING DOSE if defined
  1.  ;  3rd just use the IM med printer Variable.
  1.  ;
  1.  D:PSBCLIN]""                                             ;*70
  1.  .S PSBPRT=$$GET1^DIQ(53.46,CLIEN,4)
  1.  .S:PSBPRT="" PSBPRT=$$GET^XPAR("DIV","PSB PRINTER CO MISSING DOSE",,"E")
  1.  .S:PSBPRT="" PSBPRT=$$GET^XPAR("DIV","PSB PRINTER MISSING DOSE",,"E")
  1.  D:PSBCLIN=""                                             ;*70
  1.  .S PSBPRT=$$GET^XPAR(PSBWRD_";SC(","PSB PRINTER MISSING DOSE",,"E")
  1.  .S:PSBPRT="" PSBPRT=$$GET^XPAR("DIV","PSB PRINTER MISSING DOSE",,"E")
  1.  ;
  1.  S $P(^PSB(53.68,DA,0),U,6)=PSBPRT ; Add MG to notification
  1.  ;
  1.  ; Send the report to the specified printer
  1.  ;
  1.  D:PSBPRT]""
  1.  .W !,"Submitting Request To Pharmacy on device ",PSBPRT,"..."
  1.  .D NOW^%DTC
  1.  .S ZTIO=PSBPRT
  1.  .S ZTDTH=%
  1.  .S ZTDESC="BCMA - MISSING DOSE REQUEST"
  1.  .S ZTRTN="DQ^PSBMD("_DA_")"
  1.  .D ^%ZTLOAD
  1.  .W "Done!"
  1.  ;
  1.  ; Send the same stuff to the mail group
  1.  ;
  1.  D:PSBMG]""
  1.  .W !,"Notifying Pharmacy via Mail Group ",PSBMG,"..."
  1.  .D HFSOPEN^PSBUTL("MISSING DOSE")
  1.  .U IO D DQ(DA,1)
  1.  .D HFSCLOSE^PSBUTL("MISSING DOSE")
  1.  .S XMY("G."_PSBMG)="",XMTEXT="^TMP(""PSBO"",$J,"
  1.  .S XMSUB="BCMA - Missing Dose Request"
  1.  .D ^XMD
  1.  .W "Done!"
  1.  Q
  1.  ;
  1. DQ(PSBMD,PSBMM) ; Dequeue report from Taskman
  1.  N PSBFLD,PSBRET,DDIEN
  1.  Q:'$D(^PSB(53.68,PSBMD,0))
  1.  L +^PSB(53.68,PSBMD):$S($G(DILOCKTM)>0:DILOCKTM,1:3) ; PSB*3*23
  1.  S PSBCFLD=$P(^PSB(53.68,PSBMD,.1),U,3)
  1.  L -^PSB(53.68,PSBMD) ; PSB*3*23
  1.  D:'$G(PSBMM)  ; It is not a mail message
  1.  .W !,$TR($J("",75)," ","=")
  1.  .W !,"Report:       MISSING DOSE REQUEST"
  1.  .W !,"Date Created: " D NOW^%DTC S Y=% D D^DIQ W Y
  1.  .W !,$TR($J("",75)," ","="),!
  1.  ;I $G(PSBCFLD)'="" F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.13,.14,.19,.15,.16,.17 D OUT  ;*70
  1.  ;I $G(PSBCFLD)="" F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.25,.15,.19,.16,.17 D OUT  ;*70
  1.  ;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)
  1.  ;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)
  1.  I $G(PSBCFLD)'="" D   ;*106 - added HAZ notifications for dispensed drugs
  1.  . F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.13 D OUT
  1.  . S DDIEN=$$GET1^DIQ(53.68,PSBMD,.13,"I") D HAZOUT(DDIEN,31)
  1.  . F PSBFLD=.14,.19,.15,.16,.17 D OUT  ;*70
  1.  I $G(PSBCFLD)="" F PSBFLD=.01,.02,.03,.04,.05,.06,.11,.12,.18,1,.25,.15,.19,.16,.17 D OUT  ;*70
  1.  I $D(^PSB(53.68,PSBMD,.6)) S X=0 D   ;*106 - added HAZ notifications for additives
  1.  . 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
  1.  . . S DDIEN=$$GET1^DIQ(52.6,+^PSB(53.68,PSBMD,.6,X,0),1,"I") D HAZOUT(DDIEN,14)
  1.  I $D(^PSB(53.68,PSBMD,.7)) S X=0 D   ;*106 - added HAZ notifications for solutions
  1.  . 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
  1.  . . S DDIEN=$$GET1^DIQ(52.7,+^PSB(53.68,PSBMD,.7,X,0),1,"I") D HAZOUT(DDIEN,14)
  1.  Q
  1. OUT ;
  1.  D FIELD^DID(53.68,PSBFLD,"","LABEL","PSBRET")
  1.  W !?3,PSBRET("LABEL"),":" F  Q:$X>30  W "."
  1.  W $$GET1^DIQ(53.68,PSBMD_",",PSBFLD)
  1.  I PSBFLD=.11 D
  1.  .N DFN,VA,VADM S DFN=$$GET1^DIQ(53.68,PSBMD_",",.11,"I") D DEM^VADPT
  1.  .W !?3,$$GET^XPAR("ALL","PSB PATIENT ID LABEL")
  1.  .I $G(DUZ("AG"))="I" D
  1.  ..W ":" F  Q:$X>30  W "."
  1.  .E  D
  1.  ..W " (LAST 4 NUMBERS):" F  Q:$X>30  W "."
  1.  .W VA("BID")
  1.  W:PSBFLD=.13 " ("_$P($G(^PSB(53.68,PSBMD,.1)),U,3)_")"
  1.  S ZTREQ="@"
  1.  Q
  1.  ;
  1. HAZOUT(P50,POS) ; Write warnings for drugs, additives and solutions that are Hazardous to Handle or Dispose *106
  1.  N PSBHAZ
  1.  S PSBHAZ=$$HAZ^PSSUTIL(P50)
  1.  I $P(PSBHAZ,U)!$P(PSBHAZ,U,2) W !?POS W:$P(PSBHAZ,U) "<<HAZ Handle>> " W:$P(PSBHAZ,U,2) "<<HAZ Dispose>>"
  1.  Q
  1.  ;
  1. NEW(RESULTS) ; Create a new missing dose request
  1.  ; Called interactively and via RPCBroker
  1.  N DIC
  1.  K RESULTS
  1.  I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
  1.  I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
  1.  ; Lock Log
  1.  L +^PSB(53.68,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
  1.  E  S RESULTS(0)="-1^Request Log Locked" Q
  1.  ; Generate Unique Entry and Create
  1.  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))
  1.  S DIC="^PSB(53.68,",DIC(0)="L"
  1.  S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.07///1"
  1.  K D0         ;VRN
  1.  D FILE^DICN
  1.  L -^PSB(53.68,0)
  1.  ; Okay, setup return and Boogie
  1.  I +Y<1 S RESULTS(0)="-1^Error Creating Request"
  1.  E  S RESULTS(0)=Y
  1.  Q
  1.  ;
  1. VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
  1.  N PSB,PSBFLD,PSBMSG
  1.  F PSB=1:1 Q:$P(PSBFLDS,";",PSB)=""  S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.68,DA,PSBFLD)
  1.  I $D(PSBFLD(.21)) K:PSBFLD(.21)="N" PSBFLD(.22),PSBFLD(.23)
  1.  S PSB=""  F  S PSB=$O(PSBFLD(PSB)) Q:PSB=""  D:PSBFLD(PSB)=""
  1.  .I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED"
  1.  .D FIELD^DID(53.68,PSB,"","TITLE;LABEL","PSB")
  1.  .S X="  Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL")),PSBMSG($O(PSBMSG(""),-1)+1)=X
  1.  Q:'$D(PSBMSG)  ; All is well
  1.  D MSG^DDSUTL(.PSBMSG)
  1.  S DDSERROR=1
  1.  Q
  1.  ;
  1. 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
  1.  ; to multiple divisions, allow selection of a division from the divisions defined in file #40.8.
  1.  ; The user must have at least one division from file #40.8 in his file #200 record.
  1.  K ^TMP("PSBMD",$J)
  1.  N DIR
  1.  W !
  1.  S DIR(0)="SB^A:All Divisions;O:One Division"
  1.  S DIR("?")="Select either All Divisions or One Division."
  1.  S DIR("A")="Do you want (A)ll Divisions or just (O)ne Division"
  1.  S DIR("B")="O"
  1.  D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) Q
  1.  I Y="" Q
  1.  I Y(0)="One Division" D ONE Q   ; regardless user divisions in file #200
  1.  I Y(0)="All Divisions" D ALL Q
  1.  Q
  1.  ;
  1. ALL ; user gets all divisions (current behavior); applicable to single division sites as well
  1.  S Y(0)="All Divisions"
  1.  S PSBDIV=DUZ(2)
  1.  S PSBSTIEN=+$O(^DG(40.8,"AD",DUZ(2),"")) ; current IEN for station
  1.  S Y=$$GET1^DIQ(40.8,PSBSTIEN,.01,"E")
  1.  I '$D(Y) S Y=DUZ(2)
  1.  S PSBNAME=$$NAME^XUAF4(DUZ(2))
  1.  S PSBMUDV=0
  1.  S ^TMP("PSBMD",$J)=PSBMUDV_U_PSBDIV_U_PSBNAME
  1.  Q
  1.  ;
  1. ONE ; when user selects one division from many in file #200, look at file #40.8 for a match if available
  1.  W !
  1.  S PSBSTIEN=+$O(^DG(40.8,"AD",DUZ(2),"")) ; current IEN for station
  1.  S PSBDVNM=$$GET1^DIQ(40.8,PSBSTIEN,.01,"I") ;division name
  1.  S DIC("B")=PSBDVNM
  1.  S DIC("A")="Select Division: ",DIC="^DG(40.8,",DIC(0)="AEMQ",DIC("S")="I $$SITE^VASITE(,+Y)>0"
  1.  D ^DIC
  1.  ; capture the division name and number after user selection
  1.  S PSBNAME=$$GET1^DIQ(40.8,+Y,.01,"E")
  1.  S PSBDPTR=$$GET1^DIQ(40.8,+Y,.07,"I") ; pointer to file #4
  1.  S PSBDIV=PSBDPTR
  1.  S ^TMP("PSBMD",$J)=PSBMUDV_U_PSBDIV_U_PSBNAME
  1.  Q
  1.  ;end of changes for PSB*3*100
  1.  ;
  1. FLWUP ; Follow-Up on missing dose
  1.  ; start PSB*3*100 changes
  1.  N D0,DIC,PSBDATA,PSBDPTR,PSBDIV,PSBDVNM,PSBNAME,PSBMUDV,PSBSTIEN,X,Y
  1.  S D0=1,PSBMUDV=$S($$GET1^DIQ(43,D0,11,"I")=1:1,1:0)
  1.  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
  1.  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
  1.  I PSBMUDV=1 D CHK1
  1.  I PSBMUDV=0 D ALL
  1.  I Y=""!(Y<0)!(Y="^") Q
  1.  S PSBDIV=$P($G(^TMP("PSBMD",$J)),U,2)
  1.  S PSBNAME=$P($G(^TMP("PSBMD",$J)),U,3)
  1.  ; end of changes for PSB*3*100
  1.  N DIR,PSBIEN,PSBX,DA,DR,DDSFILE,PSBHDR,PSBDRUG,LOC            ;*70
  1.  N PSBHAZ,DDIEN                                                ;*106
  1.  S Y="" F  Q:Y="^"  D
  1.  .K ^TMP("PSB",$J) S X=""
  1.  .;start PSB*3*100 changes: user did not select one division and will see all the records (single station functionality)
  1.  .I $G(PSBMUDV)=0 D
  1.  ..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
  1.  .;
  1.  .; user selected one division
  1.  .I $G(PSBMUDV)=1 D
  1.  ..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
  1.  .;
  1.  .I '$O(^TMP("PSB",$J,0)) W !!,"No Unresolved Missing Dose Requests Found." S Y="^" Q
  1.  .I $G(PSBMUDV)=0 S PSBHDR="Currently Unresolved Missing Dose Requests"
  1.  .I $G(PSBMUDV)=1 S PSBHDR="Currently Unresolved Missing Dose Requests for: "_PSBNAME
  1.  .;end of changes for PSB*3*100
  1.  .W @IOF,PSBHDR,!,$TR($J("",IOM)," ","-")
  1.  .F PSBX=0:0 S PSBX=$O(^TMP("PSB",$J,PSBX)) Q:'PSBX!(Y="^")  S PSBIEN=^(PSBX)_"," D
  1.  ..W !,$J(PSBX,2),". ",$$GET1^DIQ(53.68,PSBIEN,.01)
  1.  ..W ?25,$$GET1^DIQ(53.68,PSBIEN,.11)
  1.  ..; get correct location                                     ;*70
  1.  ..S LOC=$S($$GET1^DIQ(53.68,PSBIEN,1)]"":$$GET1^DIQ(53.68,PSBIEN,1),1:$$GET1^DIQ(53.68,PSBIEN,.12))
  1.  ..W ?57,LOC                                                  ;*70
  1.  ..S PSBDRUG=$$GET1^DIQ(53.68,PSBIEN,.13),DDIEN=$$GET1^DIQ(53.68,PSBIEN,.13,"I")           ;*106
  1.  ..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
  1.  ..I PSBDRUG="" D
  1.  ...W !?5,"UNIQUE ID: ",$$GET1^DIQ(53.68,PSBIEN,.25)
  1.  ...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)
  1.  ...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)
  1.  ..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
  1.  .S:Y'="^" Y=$$PAGE(PSBX)
  1.  K ^TMP("PSB",$J),^TMP("PSBMD",$J) ; PSB*3*100
  1.  Q
  1.  ;
  1. PAGE(PSBIX) ;
  1.  ;
  1.  N X,X1,PSBCX,PSBDX
  1.  S DIR("A")="Select Missing Dose Request # (<RET> to continue, '^' to quit)"
  1.  I PSBIX="" S DIR("A")="Select Missing Dose Request # (<RET> or '^' to quit)"
  1.  S DIR(0)="NO^1:"_$S(PSBIX="":$O(^TMP("PSB",$J,PSBX),-1),1:PSBIX)_":0"
  1.  D ^DIR S PSBDX=+Y
  1.  I PSBIX="",Y="" S Y="^" Q Y
  1.  I $G(DTOUT) S Y="^" Q Y
  1.  I Y="^" Q Y
  1.  I Y="" W @IOF,PSBHDR,!,$TR($J("",IOM)," ","-") Q Y
  1.  S (DA,PSBCX)=^TMP("PSB",$J,+Y),DR="[PSB MISSING DOSE FOLLOWUP]",DDSFILE=53.68
  1.  D  Q Y
  1.  .D ^DDS
  1.  .; start changes for PSB*3*100
  1.  .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
  1.  .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
  1.  .; stop printing header twice (old bug) by checking PSBX before setting it to zero.
  1.  .I PSBX>0 S PSBX=0 W @IOF,PSBHDR,!,$TR($J("",IOM)," ","-")
  1.  ; end of changes for PSB*3*100
  1.  ;
  1. POST ;call from 'Patient' field of screenman form PSB MISSING DOSE REQUEST
  1.  ; 
  1.  N DFN
  1.  S DFN=X D IN5^VADPT
  1.  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
  1.  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
  1.  D REFRESH^DDSUTL
  1.  Q