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

PSBO.m

Go to the documentation of this file.
  1. PSBO ;BIRMINGHAM/EFC - BCMA OUTPUTS ;03/06/16 3:06pm
  1. ;;3.0;BAR CODE MED ADMIN;**13,32,2,25,28,51,50,42,58,68,70,83**;Mar 2004;Build 89
  1. ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1. ;
  1. ; Reference/IA
  1. ; ^ORD(101.24/3429
  1. ; ^PSDRUG(/221
  1. ;
  1. ;*68-Add PSBSIFL as 19th parameter to RPC tag to control printing of
  1. ; special instruction/other print info.
  1. ;*58 - Tag WRAP previously wrapped on a max text limit of 250 char.
  1. ; Since the use of Enhanced Order Checks, that limit has to
  1. ; be removed and the length of the input string will be used.
  1. ;*70 - Add PSBCLINORD as 20th parameter to RPC tag to control the
  1. ; type of order to appear on reports that want to be able to
  1. ; show Clinic Orders or IM orders. Set C=CO I=IM
  1. ; CCR #1459: Adding clinic to BL and BZ chui labels.
  1. ;*83 - Add call to cleanup all PSB* variables for all reports run.
  1. ;
  1. RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST,PSBPST,PSBTR,PSBDIV,PSBSIFL,PSBCLINORD,PSB21,PSB22,PSB23,PSB24,PSB25,PSBCLLST) ;
  1. ;
  1. ; RPC: PSB REPORT
  1. ;
  1. ; Description:
  1. ; Used by the client to create individual patient extracts of
  1. ; CHUI report options to display on the client.
  1. ;
  1. ;
  1. S RESULTS=$NAME(^TMP("PSBO",$J))
  1. N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
  1. N PSBMODE ;*70
  1. K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
  1. S DFN=PSBDFN
  1. D NEW^PSBO1(.PSBRPT,PSBTYPE)
  1. I PSBDFN'="",PSBTYPE="MH"!(PSBTYPE="WA")!(PSBTYPE="ML")!(PSBTYPE="MT") D PAINCMT^PSBCSUTL(PSBDFN) ;;Add Comment if Pain Score entered in BCMA was marked "Entered in Error" in Vitals.
  1. I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
  1. S PSBIENS=+PSBRPT(0)_","
  1. S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
  1. S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
  1. D:$G(PSBDEV)]""
  1. .D NOW^%DTC
  1. .I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
  1. .I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
  1. D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
  1. S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
  1. I "^SF"[("^"_PSBTYPE) D VAL^DIE(53.69,PSBIENS,.51,"F",PSBSORT,"PSBRET","PSBFDA")
  1. S PSBPST=$TR($G(PSBPST),"^",",")
  1. D VAL^DIE(53.69,PSBIENS,.52,"F",PSBPST,"PSBRET","PSBFDA")
  1. S PSBTR=$TR($G(PSBTR),"^",",")
  1. I $G(PSBDIV)]"" D VAL^DIE(53.69,PSBIENS,.04,"F",$G(PSBDIV),"PSBRET","PSBFDA")
  1. D VAL^DIE(53.69,PSBIENS,2,"F",PSBTR,"PSBRET","PSBFDA")
  1. D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
  1. I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
  1. D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
  1. D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
  1. D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
  1. D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
  1. D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
  1. D:$G(PSBINCL)]""
  1. .D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
  1. D:$G(PSBFUTR)]""
  1. .D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
  1. .D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
  1. ;*68 add SIOPI flag when present
  1. D:$D(PSBSIFL)
  1. .D VAL^DIE(53.69,PSBIENS,3,"F",PSBSIFL,"PSBRET","PSBFDA")
  1. ;*70 add PSBCLINORD indicator when present
  1. D:$D(PSBCLINORD)
  1. .D VAL^DIE(53.69,PSBIENS,4,"F",PSBCLINORD,"PSBRET","PSBFDA")
  1. D FILE^DIE("","PSBFDA")
  1. I "^SF"'[("^"_PSBTYPE) I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
  1. I "^SF"'[("^"_PSBTYPE) I $G(PSBCLLST(0),"")]"" D LIST^PSBO1(.PSBCLLST)
  1. I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
  1. D HFSOPEN^PSBUTL("RPC") I POP S ^TMP("PSBO",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$DEFDIR^%ZISH(),^TMP("PSBO",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEGES." Q
  1. U IO D DQ(+PSBIENS)
  1. D HFSCLOSE^PSBUTL("RPC")
  1. S RESULTS=$NAME(^TMP("PSBO",$J))
  1. D:$G(PSBDEV)]"" PRINT^PSBO1
  1. Q
  1. ;
  1. XQ(PSBTYPE) ; Called via Kernel Menus
  1. N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE,PSBCNT
  1. D NEW^PSBO1(.PSBRPT,PSBTYPE)
  1. I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
  1. S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
  1. W @IOF
  1. I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
  1. D:PSBSAVE
  1. .;Check Drug to Patient Relationship.
  1. .I (PSBTYPE="BL")!(PSBTYPE="BZ") S PSBANS="" D CHECK^PSBO1 I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
  1. .;
  1. .;*70 (CCR #1459 begin)
  1. .I $O(PSBCL(""))]"" D
  1. ..N PSBI
  1. ..S PSBCL="" F PSBI=0:1 S PSBCL=$O(PSBCL(PSBCL)) Q:PSBCL=""
  1. ..I PSBI=1 D Q
  1. ...S PSBCL=$O(PSBCL(PSBCL)),$P(^PSB(53.69,DA,4),U,3)=$O(^SC("B",PSBCL,""))
  1. ..;
  1. ..K DIR,Y
  1. ..;
  1. ..S PSBCL="" F PSBCNT=3:1 S PSBCL=$O(PSBCL(PSBCL)) Q:PSBCL="" D
  1. ...S DIR("A",PSBCNT)=(PSBCNT-2)_". "_PSBCL,PSBCL(PSBCL)=(PSBCNT-2)
  1. ..;
  1. ..S DIR(0)="NAO^1:"_(PSBCNT-3) ;,DIR("B")=(PSBCNT-3)
  1. ..S DIR("A",1)="Select the appropriate clinic:"
  1. ..S DIR("A",2)=""
  1. ..S DIR("A",(PSBCNT+1))=""
  1. ..S DIR("A")="Enter a number 1 thru "_(PSBCNT-3)_": "
  1. ..S DIR("?")="Select a number from 1 - "_(PSBCNT-3)_" or <Return> to exit"
  1. ..;
  1. ..D ^DIR
  1. ..I Y=""!(Y=-1)!(Y=U) S PSBANS=0 Q
  1. ..S PSBCL="" F S PSBCL=$O(PSBCL(PSBCL)) Q:PSBCL="" D
  1. ...I PSBCL[" (Ward)" Q
  1. ...I Y=PSBCL(PSBCL) S $P(^PSB(53.69,DA,4),U,3)=$O(^SC("B",PSBCL,""))
  1. .K PSBCL
  1. .I $G(PSBANS)=0 D Q
  1. ..W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
  1. .;*70 (CCR #-1459 end)
  1. .;
  1. .;Allow "'BROWSER" Device
  1. .S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
  1. ..S IOP="`"_IOP,%ZIS="N"
  1. ..D ^%ZIS
  1. ..I IO=IO(0) S PSBSIO=1
  1. ..D HOME^%ZIS K IOP
  1. .I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ(DA) D ^%ZISC K IOP Q
  1. .;
  1. .W @IOF,"Submitting Your Report Request to TaskMan..."
  1. .S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
  1. .S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
  1. .S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
  1. .S ZTRTN="DQ^PSBO("_DA_")"
  1. .D ^%ZTLOAD
  1. .W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
  1. K ^TMP("PSBO",$J)
  1. Q
  1. ;
  1. DQ(PSBRPT) ; Dequeue report from Taskman
  1. N PSBDFN
  1. Q:'$D(^PSB(53.69,PSBRPT,0)) ; No Such Report
  1. S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
  1. D SETUP,@("EN^PSBO"_$P(PSBRPT(0),U,5))
  1. K ^TMP("PSBO",$J),PSBSIFLG
  1. S ZTREQ="@"
  1. D CLEAN^PSBVT ;*83 cleanup all PSB* variables for all reports called
  1. Q
  1. ;
  1. IOM() ; Returns good margin or not
  1. Q:IOM'<132 1
  1. W !,"**************************************************************"
  1. W !,"* SORRY, Your selected DEVICE does not print 132 columns. *"
  1. W !,"**************************************************************"
  1. W !
  1. Q 0
  1. ;
  1. VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
  1. N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
  1. F PSB=1:1 Q:$P(PSBFLDS,";",PSB)="" S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
  1. I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
  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",PSBMSG(3)=" "
  1. .D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
  1. .S Z=" Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
  1. .S PSBMSG($O(PSBMSG(""),-1)+1)=Z
  1. ; Check Times
  1. D:$G(PSBFLD(.16))
  1. .S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
  1. .D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
  1. ..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42) ;check maxdays
  1. ..S:PSBDAYS="" PSBDAYS=7
  1. ..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS ;Determine stop date
  1. .S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
  1. .I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" Date: Stop Date/Time is before Start Date/Time"
  1. .I $P($$GET1^DIQ(53.69,DA_",",.01),U)["MH" S X=PSBSTOP\1 D H^%DTC I %H>PSBST S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter"
  1. Q:'$D(PSBMSG) ; All is well
  1. D MSG^DDSUTL(.PSBMSG)
  1. S DDSERROR=1
  1. Q
  1. ;
  1. SETUP ; Setup parameters for the report in PSBRPT
  1. N PSBWRDL,PSBINDX,PSBWRDA,QQ,PSBSORT,RECS
  1. S RECS=0 ;init RECS found to 0 *70
  1. K ^TMP("PSBO",$J)
  1. F X=0,.1,.2,.3,.4,.5,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
  1. I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
  1. I $D(^PSB(53.69,PSBRPT,3)) M PSBRPT(3)=^PSB(53.69,PSBRPT,3)
  1. I $D(^PSB(53.69,PSBRPT,4)) M PSBRPT(4)=^PSB(53.69,PSBRPT,4) ;*68
  1. I $G(PSBRPT(4))="" S PSBRPT(4)="^I^" ;if null def to I *70
  1. S PSBRPT(.52)=$P($G(^PSB(53.69,PSBRPT,.5)),U,2)
  1. S PSBSIFLG=$P($G(PSBRPT(4)),U) ;*68
  1. S PSBCLINORD=$S($P($G(PSBRPT(4)),U,2)="C":1,1:0)
  1. I $P(PSBRPT(0),"-")="ST",PSBRPT(3)]"" Q ;Running a MSF report PSB*3*28
  1. I $P(PSBRPT(0),"-")="SF",PSBRPT(.52)]"" Q ;Running a MSF report PSB*3*28
  1. ;
  1. S PSBSORT=$P(PSBRPT(.1),U,1) ;init PSBSORT ;*70
  1. ;
  1. ;* * Patient Mode * *
  1. I PSBSORT="P" D I 'PSBDFN Q RECS
  1. .S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN
  1. .N VA,VADM S DFN=PSBDFN D DEM^VADPT
  1. .Q:(VADM(1)="")!(VA("PID")="")
  1. .S ^TMP("PSBO",$J,PSBDFN,0)=VADM(1)_U_VA("PID"),^TMP("PSBO",$J,"B",VADM(1),PSBDFN)=""
  1. .S RECS=1
  1. ;
  1. ;* * WARDs per Nurse file group & All patient DFN's * * ;*70
  1. I PSBSORT="W" D
  1. .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD
  1. .D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
  1. .Q:$O(PSBWRDA(""))=""
  1. .S QQ="" F S QQ=$O(PSBWRDA(PSBWRD,2,QQ)) Q:QQ="" S PSBWRDL=$P(PSBWRDA(PSBWRD,2,QQ,.01),U,2) D
  1. ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN D
  1. ...S DFN=PSBDFN D DEM^VADPT
  1. ...Q:(VADM(1)="")!(VA("PID")="")
  1. ...S ^TMP("PSBO",$J,PSBDFN,0)=VADM(1)_U_VA("PID")
  1. ...; Determine Sort or default to Pt Name...
  1. ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=VADM(1)
  1. ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
  1. ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=VADM(1)
  1. ...S:$G(PSBINDX)="" PSBINDX=VADM(1)
  1. ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
  1. .S:$D(^TMP("PSBO",$J)) RECS=1
  1. ;
  1. ;* * Clinics selected & All patient DFN's * * ;*70
  1. I PSBSORT="C" D
  1. .Q:'$D(PSBRPT(2)) ;no Clinics selected
  1. .D CLIN(.PSBRPT)
  1. .M ^TMP("PSBO",$J)=^TMP("PSJCL",$J) K ^TMP("PSJCL",$J)
  1. .S:$D(^TMP("PSBO",$J)) RECS=1
  1. ;
  1. Q
  1. ;Q RECS
  1. ;
  1. WRAP(X,Y,Z) ; Quick text wrap
  1. ;
  1. ; Input Parameters Description:
  1. ; X: Left Column of display [Optional]
  1. ; Y: Cols to wrap in [Optional]
  1. ; Z: Text to wrap [Optional]
  1. ;
  1. N PSB
  1. F Q:'$L(Z) D
  1. .W:$X>X !
  1. .W:$X<X ?X
  1. .I $L(Z)<Y W Z S Z="" Q
  1. .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
  1. .S:PSB<1 PSB=Y
  1. .W $E(Z,1,PSB)
  1. .S Z=$E(Z,PSB+1,$L(Z))
  1. Q ""
  1. ;
  1. PRNEFF(PSBEIECMT,PSBIEN) ;Check for PRN Error comment
  1. N PSBCMTCH
  1. I $P($G(PSBRPT(.2)),U,8)=0 S PSBCMTCH=0 F S PSBCMTCH=$O(^PSB(53.79,PSBIEN,.3,PSBCMTCH)) Q:PSBCMTCH="" D
  1. .I $P($G(^PSB(53.79,PSBIEN,.3,PSBCMTCH,0)),U)["**Pain Score of" S PSBEIECMT=" **This Pain Score may have been Entered in Error. See Vitals Package.**"
  1. Q PSBEIECMT
  1. ;
  1. FILTERCO ; rebuild TMP using needed recs and remove clinics not wanted
  1. N QQ,COCNT,CLNAM
  1. I '$G(PSBIENS) N PSBIENS S PSBIENS=PSBRPT
  1. S COCNT=0 K ^TMP("PSJTMP",$J)
  1. K ^TMP("PSJTMP",$J)
  1. F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
  1. . Q:$P($G(^TMP("PSJ",$J,QQ,0)),U,3)["P"
  1. . S CLNAM=$P($G(^TMP("PSJ",$J,QQ,0)),U,11) Q:CLNAM="" ;Not a CO
  1. . ;ignore orders that are CO and for a Clinic not asked for
  1. . I CLNAM]"",'$D(^PSB(53.69,+PSBIENS,2,"B",CLNAM)) Q
  1. . S COCNT=COCNT+1
  1. . M ^TMP("PSJTMP",$J,COCNT)=^TMP("PSJ",$J,QQ)
  1. K ^TMP("PSJ",$J) M ^TMP("PSJ",$J)=^TMP("PSJTMP",$J)
  1. K ^TMP("PSJTMP",$J)
  1. S:'$D(^TMP("PSJ",$J)) ^TMP("PSJ",$J,1,0)=-1
  1. Q
  1. ;
  1. CLIN(RPTARR,DFNLST) ;Build DFN list of patient orders per Clinics selected
  1. ; Input: RPTARR - Report request array from file 53.69. (required)
  1. ; DFNLST - pass by ref array name if array needed and not
  1. ; a tmp global pass a 1. (optional)
  1. ; default is TMP global
  1. ; DFNLST - array of DFN's only
  1. ;
  1. N DFNARR,GLB,ROOT,STARTDT
  1. K ^TMP("PSJCL",$J)
  1. S STARTDT=$P($G(RPTARR(.1)),U,6)
  1. S:STARTDT="" STARTDT=$P($$NOW^XLFDT,".")
  1. ;
  1. ;Begin query read with Unit Dose xref and report start date range
  1. S GLB=$NA(^PS(55,"AUDC",STARTDT)),ROOT=$E(GLB,1,13)
  1. D QUERY(GLB,ROOT,9999999,.RPTARR,.DFNARR)
  1. ;
  1. ;Now do query read for IV xref and report start date range
  1. S GLB=$NA(^PS(55,"AIVC",STARTDT)),ROOT=$E(GLB,1,13)
  1. D QUERY(GLB,ROOT,9999999,.RPTARR,.DFNARR)
  1. ;
  1. I $G(DFNLST) M DFNLST=DFNARR Q ;if DFNLST then return array and quit
  1. D BLDTMP(.DFNARR)
  1. Q
  1. ;
  1. QUERY(GLB,ROOT,RPSTOPDT,RPTAR,DFNAR) ;Loops thru global xref via $Query
  1. ; for qualifying recs to find DFN's
  1. N CLN,CLNNAM,DFN,STPDT,NOD1,NOD2
  1. I GLB["UD" D
  1. .S NOD1=5,NOD2=8
  1. E D
  1. .S NOD1="IV",NOD2="DSS"
  1. ;
  1. F S GLB=$Q(@GLB) Q:$E(GLB,1,13)'=ROOT D
  1. .S STPDT=$P($QS(GLB,3),"."),CLN=$QS(GLB,4),DFN=$QS(GLB,5),OR=$QS(GLB,6)
  1. .Q:$D(DFNAR(DFN)) ;quit if DFN already on ARR
  1. .S CLNODE=$G(^PS(55,DFN,NOD1,OR,NOD2))
  1. .Q:'$$CLINIC(CLNODE) ;not active bcma clin order
  1. .S CLNNAM=$$GET1^DIQ(44,CLN,.01) ;get clinic name
  1. .Q:STPDT>RPSTOPDT ;quit if rec beyond stop date
  1. .Q:'$D(RPTAR(2,"B",CLNNAM)) ;quit if Not on Cln sel list
  1. .;
  1. .S DFNAR(DFN)="" ;Keep - Set DFN in array
  1. Q
  1. ;
  1. BLDTMP(ARR) ;Build Tmp global for DFN's to be included on the report
  1. N VA,VADM,PSJINDX
  1. F DFN=0:0 S DFN=$O(ARR(DFN)) Q:'DFN D
  1. .K VA,VADM D DEM^VADPT
  1. .Q:(VADM(1)="")!(VA("PID")="")
  1. .S ^TMP("PSJCL",$J,DFN,0)=VADM(1)_U_VA("PID")
  1. .S PSJINDX=VADM(1)
  1. .S ^TMP("PSJCL",$J,"B",PSJINDX,DFN)=""
  1. .S RECS=1
  1. Q
  1. ;
  1. CLINIC(CL) ;Is this a Clinic order that would show on the VDL in CO mode also?
  1. Q:'($P(CL,"^",2)?7N!($P(CL,"^",2)?7N1".".N)) 0 ;no appt date, IM ord
  1. Q:'$D(^PS(53.46,"B",+CL)) 0 ;no PTR to 44, IM ord
  1. N A S A=$O(^PS(53.46,"B",+CL,"")) Q:'A 0 ;no 53.46 ien, IM ord
  1. Q $P(^PS(53.46,A,0),"^",4) ;Send to BCMA? flag