PSBO ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004 ;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified. ; Reference/IA ; ^DPT(/10035 ; WARD^NURSUT5/3052 ; EN^PSJBCMA/2828 ; ^ORD(101.24/3429 ; ^PSDRUG(/221 RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST) ; ; ; RPC: PSB REPORT ; ; Description: ; Used by the client to create individual patient extracts of ; CHUI report options to display on the client. ; S RESULTS=$NAME(^TMP("PSBO",$J)) N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^" S DFN=PSBDFN D NEW^PSBO1(.PSBRPT,PSBTYPE) I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q S PSBIENS=+PSBRPT(0)_"," S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1 S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1 D:$G(PSBDEV)]"" .D NOW^%DTC .I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA") .I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA") D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA") S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA") D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA") I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA") D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA") D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA") D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA") D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA") D:$G(PSBINCL)]"" .D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA") D:$G(PSBFUTR)]"" .D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA") .D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA") D FILE^DIE("","PSBFDA") I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST) I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q D HFSOPEN^PSBUTL("RPC") I POP S ^TMP("PSBO",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$GET^XPAR("DIV","PSB HFS SCRATCH"),^TMP("PSBO",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEDGES." Q U IO D DQ(+PSBIENS) D HFSCLOSE^PSBUTL("RPC") S RESULTS=$NAME(^TMP("PSBO",$J)) D:$G(PSBDEV)]"" PRINT^PSBO1 Q ; XQ(PSBTYPE) ; Called via Kernel Menus N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE D NEW^PSBO1(.PSBRPT,PSBTYPE) I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS W @IOF I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" D:PSBSAVE .;Check Drug to Patient Relationship. .I PSBTYPE="BL" S PSBANS="" D CHECK I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q .; .;Allow "'BROWSER" Device .S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D ..S IOP="`"_IOP,%ZIS="N" ..D ^%ZIS ..I IO=IO(0) S PSBSIO=1 ..D HOME^%ZIS K IOP .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 .W @IOF,"Submitting Your Report Request to Taskman..." .S ZTIO=$$GET1^DIQ(53.69,DA_",",.06) .S ZTDTH=$P(^PSB(53.69,DA,0),U,7) .S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05) .S ZTRTN="DQ^PSBO("_DA_")" .D ^%ZTLOAD .W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),! K ^TMP("PSBO",$J) Q ; DQ(PSBRPT) ; Dequeue report from Taskman N PSBWRD,PSBDFN Q:'$D(^PSB(53.69,PSBRPT,0)) ; No Such Report S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC") D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5)) K ^TMP("PSBO",$J) S ZTREQ="@" Q ; IOM() ; Returns good margin or not Q:IOM'<132 1 W !,"**************************************************************" W !,"* SORRY, Your selected DEVICE does not print 132 columns. *" W !,"**************************************************************" W ! Q 0 ; VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT="" F PSB=1:1 Q:$P(PSBFLDS,";",PSB)="" S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD) I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12) 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",PSBMSG(3)=" " .D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB") .S Z=" Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL")) .S PSBMSG($O(PSBMSG(""),-1)+1)=Z ; Check Times D:$G(PSBFLD(.16)) .S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17)) .D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH" ..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42) ;check maxdays ..S:PSBDAYS="" PSBDAYS=7 ..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS ;Determine stop date .S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19)) .I PSBSTOPPSBST 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" Q:'$D(PSBMSG) ; All is well D MSG^DDSUTL(.PSBMSG) S DDSERROR=1 Q ; SETUP() ; Setup parameters for the report in PSBRPT N PSBWRDL,PSBINDX,PSBWRDA K ^TMP("PSBO",$J) F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X)) I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2) I $P(PSBRPT(.1),U,1)="P" S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9),^TMP("PSBO",$J,"B",$P(^DPT(PSBDFN,0),U),PSBDFN)="" D:$P(PSBRPT(.1),U,1)="W" .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA) .S X="" F S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X="" S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN D ...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9) ...; Determine Sort or default to Pt Name... ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U) ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **" ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U) ...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U) ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)="" Q 1 ; WRAP(X,Y,Z) ; Quick text wrap ; ; Input Parameters Description: ; X: Left Column of display [Optional] ; Y: Cols to wrap in [Optional] ; Z: Text to wrap [Optional] ; N PSB F Q:'$L(Z) D .W:$X>X ! .W:$X