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

PSBUTL.m

Go to the documentation of this file. 
  1. PSBUTL ;BIRMINGHAM/EFC-BCMA UTILITIES ;29-May-2012 14:23;PLS
  1.  ;;3.0;BAR CODE MED ADMIN;**3,9,13,38,45,46,1010,1015**;Mar 2004;Build 62
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; Reference/IA
  1.  ; $$PATCH & $$VERSION^XPDUTL/10141
  1.  ; File 50/221
  1.  ; File 200/10060
  1.  ;Modified - IHS/MSC/PLS - 08/24/10 - Line HFSOPEN+2
  1.  ;
  1. DIWP(X,Y,PSB,PSBARGN) ;
  1.  K ^UTILITY($J,"W")
  1.  S DIWL=0,DIWR=Y,DIWF="C"_Y D ^DIWP
  1.  F X=0:0 S X=$O(^UTILITY($J,"W",0,X)) Q:'X  D
  1.  .S Y=$O(@PSB@(""),-1)+1
  1.  .; Naked Ref ^UTILITY($J,"W",0,X)
  1.  .S @PSB@(Y)=$J("",+$G(PSBARGN))_^(X,0)
  1.  S @PSB@(0)=+$O(@PSB@(""),-1)
  1.  K ^UTILITY($J,"W"),DIWL,DIWR,DIWF
  1.  Q
  1.  ;
  1. SATURDAY(X,PSBDISP) ;
  1.  S X=X\1 D H^%DTC ; Convert to $H
  1.  S %H=%H+(6-%Y) ;   Set it forward to Saturday
  1.  D YMD^%DTC ;       Back to FM Format
  1.  I $G(PSBDISP) S PSBDISP=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) D EN^DDIOL("Actual date is Saturday "_PSBDISP)
  1.  Q X
  1.  ;
  1. SUNDAY(X,PSBDISP) ;
  1.  S X=X\1 D H^%DTC ; Convert to $H
  1.  S %H=%H-%Y ;       Set it back to Sunday
  1.  D YMD^%DTC ;       Back to FM Format
  1.  I $G(PSBDISP) S PSBDISP=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) D EN^DDIOL("Actual date is Sunday "_PSBDISP)
  1.  Q X
  1.  ;
  1. CLOCK(RESULTS,X) ; Verify Client/Server Date/Times are close enough
  1.  ;
  1.  ; RPC: PSB SERVER CLOCK VARIANCE
  1.  ;
  1.  ; Description:
  1.  ; Returns variance from server to client in minutes
  1.  ;
  1.  N PSBCLNT,PSBSRVR,PSBDIFF
  1.  S %DT="RS" D ^%DT S PSBCLNT=Y
  1.  D NOW^%DTC S PSBSRVR=%
  1.  S PSBDIFF=$$DIFF(PSBSRVR,PSBCLNT)
  1.  S X=$$GET^XPAR("DIV","PSB SERVER CLOCK VARIANCE")
  1.  I PSBDIFF>X!(PSBDIFF<(X*-1)) S RESULTS(0)="-1^"_PSBDIFF
  1.  E  S RESULTS(0)="1^"_PSBDIFF
  1.  Q
  1.  ;
  1. DIFF(X,X1) ; Difference in minutes between 2 FM dates
  1.  ; Code copied from Fileman Function MINUTES
  1.  S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) D ^%DTC:X S X=X*1440+Y
  1.  Q X
  1.  ;
  1. DRUGINQ ; Drug File Inquiry
  1.  N PSBRET,PSBIEN,DIC,DIR,IOINORM,IOINHI
  1.  S X="IOINHI;IOINORM" D ENDR^%ZISS
  1.  S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  S DIC="^PSDRUG(",DIC(0)="AEQMVTN",DIC("T")="",D="B^C^VAPN^VAC^NDC^XATC",DIC("A")="Select DRUG: "
  1.  ; Display active drugs and those for appl packages IV and Unit Dose
  1.  S DIC("S")="I '$G(^PSDRUG(+Y,""I""))!($G(^(""I""))>DT),$P($G(^PSDRUG(+Y,2)),U,3)[""I""!($P($G(^PSDRUG(+Y,2)),U,3)[""U"")"
  1.  F  W @IOF,!,"DRUG FILE INQUIRY",! D ^DIC  Q:+Y<1  D
  1.  .K PSBRET
  1.  .S PSBIEN=+Y_","
  1.  .D GETS^DIQ(50,PSBIEN,".01;16;25;51;215;213;101;9*","","PSBRET")
  1.  .W @IOF,!,"DRUG NAME: ",IOINHI,PSBRET(50,PSBIEN,.01)
  1.  .W "  (IEN: ",+PSBIEN,")",IOINORM,!,$TR($J("",IOM)," ","-"),!
  1.  .F X=16,25,51,215,213,101 D
  1.  ..D FIELD^DID(50,X,"","LABEL","PSBRET")
  1.  ..W !,PSBRET("LABEL"),":",?30,IOINHI
  1.  ..D:$L(PSBRET(50,PSBIEN,X))>49
  1.  ...F Y=1:1 Q:$L($P(PSBRET(50,PSBIEN,X)," ",1,Y))>49
  1.  ...W $P(PSBRET(50,PSBIEN,X)," ",1,Y-1),!?30
  1.  ...S PSBRET(50,PSBIEN,X)=$P(PSBRET(50,PSBIEN,X)," ",Y,250)
  1.  ..W ?30,PSBRET(50,PSBIEN,X),IOINORM
  1.  .W !!,"SYNONYMS:",IOINHI,!?15
  1.  .S X="" F  S X=$O(PSBRET(50.1,X)) Q:X=""  W:$X>40 !?15 W:$X>15 ?40 W PSBRET(50.1,X,.01)
  1.  .W IOINORM
  1.  .F  Q:$Y>(IOSL-3)  W !
  1.  .S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;
  1. DPTSET ; Set Logic for pt-merge x-ref on patient field in file 53.79
  1.  ;
  1.  ; Entered Date/Time
  1.  I $P(^PSB(53.79,DA,0),U,4) S ^PSB(53.79,"AEDT",X,$P(^PSB(53.79,DA,0),U,4),DA)=""
  1.  ;
  1.  ; Administration Date/Time
  1.  D:$P(^PSB(53.79,DA,0),U,6)
  1.  .S ^PSB(53.79,"AADT",X,$P(^PSB(53.79,DA,0),U,6),DA)=""
  1.  .;
  1.  .; Orderable Item + Administration Date/Time
  1.  .I $P(^PSB(53.79,DA,0),U,8) S ^PSB(53.79,"AOIP",X,$P(^PSB(53.79,DA,0),U,8),$P(^PSB(53.79,DA,0),U,6),DA)=""
  1.  ;
  1.  ; PRN's by entered date/time
  1.  I $P($G(^PSB(53.79,DA,.1)),U,2)="P"&($P(^(0),U,4)) S ^PSB(53.79,"APRN",X,$P(^PSB(53.79,DA,0),U,4),DA)=""
  1.  ;
  1.  ; Order+Administration Date and Time
  1.  I $P($G(^PSB(53.79,DA,.1)),U)]""&($P($G(^PSB(53.79,DA,.1)),U,3)) S ^PSB(53.79,"AORD",X,$P(^PSB(53.79,DA,.1),U),$P(^PSB(53.79,DA,.1),U,3),DA)=""
  1.  Q
  1.  ;
  1. DPTKILL ; Kill Logic for pt-merge x-ref on patient field in file 53.79
  1.  ;
  1.  ; Entered Date/Time
  1.  I $P(^PSB(53.79,DA,0),U,4) K ^PSB(53.79,"AEDT",X,$P(^PSB(53.79,DA,0),U,4),DA)
  1.  ;
  1.  ; Administration Date/Time
  1.  D:$P(^PSB(53.79,DA,0),U,6)
  1.  .K ^PSB(53.79,"AADT",X,$P(^PSB(53.79,DA,0),U,6),DA)
  1.  .;
  1.  .; Orderable Item + Administration Date/Time
  1.  .I $P(^PSB(53.79,DA,0),U,8) K ^PSB(53.79,"AOIP",X,$P(^PSB(53.79,DA,0),U,8),$P(^PSB(53.79,DA,0),U,6),DA)
  1.  ;
  1.  ; PRN's by entered date/time
  1.  I $P($G(^PSB(53.79,DA,.1)),U,2)="P"&($P(^(0),U,4)) K ^PSB(53.79,"APRN",X,$P(^PSB(53.79,DA,0),U,4),DA)
  1.  ;
  1.  ; Order+Administration Date and Time
  1.  I $P($G(^PSB(53.79,DA,.1)),U)]""&($P($G(^PSB(53.79,DA,.1)),U,3)) K ^PSB(53.79,"AORD",X,$P(^PSB(53.79,DA,.1),U),$P(^PSB(53.79,DA,.1),U,3),DA)
  1.  Q
  1.  ;
  1. TIMEIN ;
  1.  X ^%ZOSF("UPPERCASE") S X=Y
  1.  I X="NOON" S X=.12 Q
  1.  I X="MID" S X=.24 Q
  1.  I (X="NOW")!(X="N") D NOW^%DTC S X=$E($P(%,".",2)_"0000",1,4)
  1.  S X="T@"_X,%DT="R" D ^%DT
  1.  I Y<1 K X Q
  1.  S X=Y-DT
  1.  Q
  1.  ;
  1. TIMEOUT(X) ;
  1.  N HOUR,MIN,AMPM
  1.  S X=$E($P(X,".",2)_"0000",1,4)
  1.  I X="2400" Q "12:00m"
  1.  I X="1200" Q "12:00n"
  1.  S HOUR=+$E(X,1,2),MIN=$E(X,3,4)
  1.  S AMPM="a"
  1.  S AMPM=$S(HOUR<12:"a",HOUR>11:"p",1:"**")
  1.  S:HOUR>12 HOUR=HOUR-12
  1.  Q HOUR_":"_MIN_AMPM
  1.  ;
  1. HFSOPEN(HANDLE) ;
  1.  N PSBDIR,PSBFILE
  1.  S PSBDIR=$$DEFDIR^%ZISH("")  ;IHS/MSC/PLS - 08/24/2010
  1.  S PSBFILE="PSB"_DUZ_".DAT"
  1.  D OPEN^%ZISH(HANDLE,PSBDIR,PSBFILE,"W") Q:POP
  1.  S IOM=132,IOSL=99999,IOST="P-DUMMY",IOF=""""""
  1.  Q
  1.  ;
  1. HFSCLOSE(HANDLE) ;
  1.  N PSBDIR,PSBFILE,PSBDEL
  1.  D CLOSE^%ZISH(HANDLE)
  1.  K ^TMP("PSBO",$J)
  1.  S PSBDIR=$$DEFDIR^%ZISH("")
  1.  S PSBFILE="PSB"_DUZ_".DAT",PSBDEL(PSBFILE)=""
  1.  S X=$$FTG^%ZISH(PSBDIR,PSBFILE,$NAME(^TMP("PSBO",$J,2)),3)
  1.  S X=$$DEL^%ZISH(PSBDIR,$NA(PSBDEL))
  1.  Q
  1.  ;
  1. AUDIT(PSBREC,PSBDD,PSBFLD,PSBDATA,PSBSK) ; Med Log Audit
  1.  ; used by cross references to 53.79 to track changes to fields in Med Log file
  1.  ; xref AU05, AU06, AU09, AU16, AU21, AU22 pass the value 53.79 as PSBDD
  1.  ; xref AU303, AU304 pass the value 53.795 as PSBDD
  1.  ; xref AU603, AU604 pass the value 53.796 as PSBDD
  1.  ; xref AU703, AU704 pass the value 53.797 as PSBDD
  1.  ;
  1.  N PSBDT,PSBTMP
  1.  I '$D(PSBOLSTS) S PSBOLSTS=$P(^PSB(53.79,PSBREC,0),U,9)
  1.  I '$D(PSBOLDUZ) S PSBOLDUZ=$P(^PSB(53.79,PSBREC,0),U,5)
  1.  Q:$G(PSBDATA)=""!('$G(PSBAUDIT))
  1.  D NOW^%DTC S PSBDT=%
  1.  S PSBDATA=$$EXTERNAL^DILFD(PSBDD,PSBFLD,"",PSBDATA)  ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
  1.  D FIELD^DID(PSBDD,PSBFLD,"","LABEL","PSBTMP")  ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
  1.  S:'$D(^PSB(53.79,PSBREC,.9,0)) ^(0)="^53.799^^"
  1.  S Y=$O(^PSB(53.79,PSBREC,.9,""),-1)+1,X=""
  1.  I PSBTMP("LABEL")["ACTION STATUS" D  Q
  1.  .I PSBSK["K" S XY=Y F  S XY=$O(^PSB(53.79,PSBREC,.9,XY),-1) Q:($D(PSBGOON))!(+XY'>0)  D
  1.  ..I ^PSB(53.79,PSBREC,.9,XY,0)["ACTION STATUS Set to '" D  Q
  1.  ...S PSBGOON=1,PSBOLDUZ=$P(^PSB(53.79,PSBREC,.9,XY,0),U,2),X=$P(^PSB(53.79,PSBREC,.9,XY,0),"'",2)
  1.  .S:$L(X)'>2 X=PSBOLSTS,X=$S(X="G":"GIVEN",X="H":"HELD",X="R":"REFUSED",X="I":"INFUSING",X="C":"COMPLETED",X="S":"STOPPED",X="N":"NOT GIVEN",X="RM":"REMOVED",X="M":"MISSING DOSE",X="":PSBOLSTS)
  1.  .I PSBSK["K" S ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" '"_PSBDATA_"' by '"_$$GET1^DIQ(200,PSBOLDUZ,"INITIAL")_"' deleted."
  1.  .;PSB*3*45 Store Action status and last given fields.
  1.  .E  S ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" Set to '"_PSBDATA_"' by '"_$$GET1^DIQ(200,DUZ,"INITIAL")_"'."_U_PSBDATA_U_$P(^PSB(53.79,PSBREC,0),"^",7)
  1.  I PSBSK["K" S ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" '"_PSBDATA_"' deleted."
  1.  E  S ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_$S(PSBTMP("LABEL")["DISPENSE DRUG":" Added '",1:" Set to '")_PSBDATA_"'."
  1.  K XY,PSBGOON
  1.  Q
  1.  ;
  1. CHECK(RESULTS,PSBWHAT,PSBDATA) ; Checks for KIDS Patch or Build
  1.  ; Module added in Patch PSB*1.0*3 DP/TOPEKA 22-DEC-1999 11:51:22
  1.  ; PSBWHAT: B = Returns Build Version for packages by Namespace
  1.  ;          P = Returns if Patch is installed
  1.  ; PSBDATA: Build/Package namespace (i.e. PSB) or Patch Number
  1.  ;         (i.e. PSB*1.0*1)
  1.  ;
  1.  S RESULTS(0)="-1^Unknown Parameter "_$G(PSBWHAT,"<PSBWHAT Undefined>")
  1.  S PSBWHAT=$G(PSBWHAT),PSBDATA=$G(PSBDATA)
  1.  D:PSBWHAT="B"
  1.  .S X=$$VERSION^XPDUTL(PSBDATA)
  1.  .S RESULTS(0)=$S(X="":"-1^Unknown Package/Build",1:"1^"_X)
  1.  D:PSBWHAT="P"
  1.  .S X=$$PATCH^XPDUTL(PSBDATA)
  1.  .S RESULTS(0)=$S(X:"1^Patch Is Installed",1:"-1^Patch Is Not Installed")
  1.  Q
  1.  ;
  1. VERSION() ; [Extrinsic]
  1.  ; Returns V#.# for display purposes
  1.  Q "V"_$J(2,0,1)
  1.  ;
  1. RESETADM ;
  1.  ;
  1.  ;  This Subroutine will reset a medication order's resources
  1.  ;  based on Med Log New Entry or Edit Med Log activity.
  1.  ;
  1.  ;  No input is necessary. Environment should be setup at call.
  1.  ;
  1.  I '$G(PSBMMEN) S X=$S($P(PSBIEN,",",2)]"":$P(PSBIEN,",",2),1:+PSBIEN) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,X,0),U),$P(^PSB(53.79,X,.1),U)) D:($$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$G(PSBIVPSH)))  D CLEAN^PSBVT
  1.  .S X=PSBIEN,X2=X_$S(X="+1":",",1:"") Q:'$D(PSBFDA(53.79,X2,.09))  I $F("HR",PSBFDA(53.79,X2,.09))>1 S PSBFDA(53.79,X2,.26)=""
  1.  I $G(PSBMMEN),PSBIEN="+1",$G(PSBONX)["V" S PSBWSID=PSBFDA(53.79,"+1,",.26) K PSBFDA(53.79,"+1,",.26),PSBFDA(53.79,"+1,",.09)
  1.  I $G(PSBMMEN) I ($D(PSBWSID))&($G(Y(0))="SAVE") D
  1.  .S:(PSBREC(3)="G") PSBFDAX(53.79,X,.26)=PSBWSID
  1.  .S:$F("HR",PSBREC(3))>1 PSBFDAX(53.79,X,.26)=""
  1.  .S X=$P(PSBIEN,"+1,",2)
  1.  .D UPDATE^DIE("","PSBFDAX","X","PSBMSG")
  1.  Q
  1.  ;
  1. SCRNPTCH ;
  1.  ;
  1.  ; Maintain the "APATCH" index from SCREENMAN and Manual Med Entry.
  1.  ;
  1.  I Y(0)'="GIVEN" S PSBGPTCH=0 Q
  1.  S PSBX=0 F  S PSBX=$O(^PSB(53.79,DA,.5,PSBX))  Q:+PSBX=0  Q:$P(^PSB(53.79,DA,.5,+PSBX,0),U,4)="PATCH"
  1.  Q:+PSBX=0
  1.  S PSBGPTCH=1
  1.  Q
  1.  ;
  1. GIVEPTCH ;
  1.  I $D(^PSB(53.79,"AORD",DFN,PSBONX)) N PSBX S PSBX="" F  S PSBX=$O(^PSB(53.79,"AORD",DFN,PSBONX,PSBX)) Q:+PSBX=0  D:$D(^PSB(53.79,"AORD",DFN,PSBONX,PSBX,DA))  Q:'$D(PSBX)
  1.  .I $D(^PSB(53.79,"AORD",DFN,PSBONX,PSBX,DA)) D
  1.  ..S PSBX=$P(^PSB(53.79,DA,0),U,6)
  1.  ..I PSBGPTCH S ^PSB(53.79,"APATCH",DFN,PSBX,DA)="" K PSBX,PSBGPTCH Q
  1.  ..I 'PSBGPTCH K ^PSB(53.79,"APATCH",DFN,PSBX,DA),PSBX,PSBGPTCH
  1.  Q