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 ;03/06/16 3:06pm
  1. ;;3.0;BAR CODE MED ADMIN;**3,9,13,38,45,46,63,83,97,99,104,114**;Mar 2004;Build 3
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Reference/IA
  1. ; $$PATCH & $$VERSION^XPDUTL/10141
  1. ; File 50/221
  1. ; File 200/10060
  1. ; EN^PSJBCMA1/2829
  1. ;
  1. ;*83 - Add tags called by DD trigger xrefs
  1. ; - Add FIXADM to add to coversheet Results the G give action.
  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,PSBMDNT
  1. S PSBMDNT=0
  1. I $P(X,"@",2)="0000" S $P(X,"@",2)="2400",PSBMDNT=1 ;Change Delphi time for midnight from 0000 to 2400 in PSB*3.0*63
  1. S %DT="RS" D ^%DT S PSBCLNT=Y
  1. D NOW^%DTC S PSBSRVR=%
  1. S:$G(PSBMDNT) PSBCLNT=$$FMADD^XLFDT(PSBCLNT,-1,0,0,0) ;Change Delphi date for midnight from day following midnight to day previous to midnight in PSB*3.0*63
  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()
  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. Q:'$O(^PSB(53.79,0)) ;Quit if there are no BCMA entries, PSB*3*99
  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
  1. ;
  1. VALGIV() ;Validate Give, variance time set during a Trigger call *83
  1. Q:'$P($G(^PSB(53.79,DA,0)),U,6) 0
  1. Q ($P($G(^PSB(53.79,DA,.1)),U,2)="C"&($P($G(^(.1)),U,3)]"")&($G(PSBACTN)="G"))
  1. ;
  1. VALREM() ;Validate Remove, variance time set during a Trigger call *83
  1. Q:'$P($G(^PSB(53.79,DA,0)),U,6) 0
  1. Q ($P($G(^PSB(53.79,DA,.1)),U,2)="C"&($P($G(^(.1)),U,7)]"")&($G(PSBACTN)="RM"))
  1. ;
  1. REMSTR(A,D,TY,SP,PRSP) ;build remove time string from admin time string via DOA value *83
  1. ; A = admin time strg e.g. "0900-2100"
  1. ; D = Duration of Admin (DOA)
  1. ; TY = sched type
  1. ; SP = order stop date
  1. ; PRSP = previous stop date
  1. ;
  1. N RMTM,RMSTR,Q
  1. S RMSTR="",TY=$G(TY),SP=$G(SP),PRSP=$G(PRSP)
  1. ;
  1. ;no admin time, return null RMSTR
  1. Q:(TY'="O")&('A) RMSTR
  1. ;
  1. ;sched typ is One Time, return Ord stop time as RMSTR
  1. I TY="O" D Q RMSTR
  1. .S RMSTR=$S(PRSP:PRSP,1:SP),RMSTR=$E($P(RMSTR,".",2)_"0000",1,4)
  1. ;
  1. ;continuous schedules with valid admin times
  1. F Q=1:1:$L(A,"-") D
  1. .S RMTM=DT_"."_$P(A,"-",Q)
  1. .S RMTM=$$FMADD^XLFDT(RMTM,,,D)
  1. .S RMTM=$P(RMTM,".",2),RMTM=$E(RMTM_"0000",1,4)
  1. .S $P(RMSTR,"-",Q)=RMTM
  1. Q RMSTR
  1. ;
  1. CNVRT4(STR,SEP) ;Converts a time string to 4 digit for consistency *83
  1. ; STR - string of times
  1. ; SEP - separator character between times
  1. ;
  1. N QQ
  1. F QQ=1:1:$L(STR,SEP) S $P(STR,SEP,QQ)=$E($P(STR,SEP,QQ)_"0000",1,4)
  1. Q STR
  1. ;
  1. FINDGIVE(IEN) ;Finds the last Give date/time in the Audit log for a RM sts *83
  1. ; When a Remove action occurs and saved to 53.79, the Give Action
  1. ; Status & Action Date/Time are overwritten. This Function will
  1. ; retrieve that Give info.
  1. ;
  1. ; Function returns - string formatted as the MAH report uses:
  1. ;
  1. ; date/time^by initials^action code^IEN of #53.79^IEN of user #200
  1. ;
  1. Q:$P(^PSB(53.79,IEN,0),U,9)'="RM" ""
  1. N DA,DAT,GIVE,FOUND,STR,QQ,PRVDA,PRVDAT,SKIP
  1. S (FOUND,STR,GIVE)=""
  1. F DA=99999:0 S DA=$O(^PSB(53.79,IEN,.9,DA),-1) Q:'DA D Q:FOUND
  1. .S DAT=^PSB(53.79,IEN,.9,DA,0),SKIP=0
  1. .; check for previous audit to be an Undo RM, if so skip it
  1. .I DAT["ACTION STATUS Set to 'GIVEN'" D Q
  1. ..S PRVDA=$O(^PSB(53.79,IEN,.9,DA),-1) ;previous audit DA
  1. ..D:PRVDA
  1. ...S PRVDAT=^PSB(53.79,IEN,.9,PRVDA,0)
  1. ...I PRVDAT["ACTION STATUS 'REMOVED'",PRVDAT["deleted" S SKIP=1
  1. ..Q:SKIP
  1. ..S $P(STR,U,1)=$P(DAT,U,1) ;init date just in case
  1. ..S $P(STR,U,2)=$P(DAT,"'",4) ;by initials
  1. ..S $P(STR,U,3)="G" ;action sts Give
  1. ..S $P(STR,U,4)=IEN ;ien of transaction
  1. ..S $P(STR,U,5)=$P(DAT,U,2) ;ien of user file 200
  1. ..S GIVE=1
  1. .Q:SKIP
  1. .;
  1. .;preferred date of action is in external form, as manual med edits
  1. .;can be back dated and show up here vs audit date/time for the Give
  1. .D:GIVE
  1. ..Q:DAT'["DATE/TIME Set to"
  1. ..S:DAT?.E1"@".E $P(STR,U,1)=$$ETFM($P(^(0),"'",2))
  1. ..;found real date
  1. ..S FOUND=1
  1. Q STR
  1. ;
  1. ETFM(EX) ;convert external to FM date format
  1. N M,MM,MTH,TM,DY,Y,Y1,Y2,YYY,YYYY,Q
  1. S MTH=$E(EX,1,3)
  1. S Q=0
  1. F M="JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC" S Q=Q+.01,MM(M)=Q
  1. S MM=$E($P(MM(MTH),".",2)_"0",1,2)
  1. ;
  1. S DY=$P(EX," ",2),DY=$TR(DY,",","")
  1. S Y=$P(EX," ",3),YYYY=$P(Y,"@"),Y1=$E(YYYY,1,2)-17,Y2=$E(YYYY,3,4),YYYY=Y1_Y2
  1. S TM=$P(Y,"@",2),TM=$TR(TM,":","")
  1. Q $E(YYYY_MM_DY_"."_TM,1,12)
  1. ;
  1. MEDHIST(LIST,DFN,OI,MAX) ;Last nn admin actions per a patients Orderable Item
  1. ;
  1. ; Reference/IA
  1. ; #6271 for Inpatient Medications to call into BCMA *83
  1. ; ** NOTE **
  1. ; THIS API IS DIRECTLY/INDIRECTLY DEPENDANT ON 3 OTHER INTERNAL
  1. ; API's: LASTSITE^PSBINJEC, RPC^PSBVDLUD, & FINDGIVE^PSBUTL
  1. ;
  1. ; Input:
  1. ; DFN - Patient num
  1. ; OI - Inpatient Meds Orderable Item ien
  1. ; MAX - Max days back to search
  1. ; Output:
  1. ; LIST - Array of actions formatted as :
  1. ; DATE^ACTION^ORDNO^LSTSITE^LOCATION^NURSINITL
  1. ;
  1. K LIST
  1. N DTE,CNT,IEN,ACTN,GIVE,DATE,LSITE,ACTBY,NURINI,ORDN,LOC
  1. ;
  1. S DTE=DT+1
  1. F S DTE=$O(^PSB(53.79,"AOIP",DFN,OI,DTE),-1) Q:'DTE D Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
  1. .S IEN=0
  1. .F S IEN=$O(^PSB(53.79,"AOIP",DFN,OI,DTE,IEN)) Q:'IEN D Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
  1. ..S ACTN=$$GET1^DIQ(53.79,IEN,.09)
  1. ..S ORDN=$$GET1^DIQ(53.79,IEN,.11)
  1. ..S LOC=$$GET1^DIQ(53.79,IEN,.02)
  1. ..S ACTBY=$$GET1^DIQ(53.79,IEN,.07,"I")
  1. ..S NURINI=$$GET1^DIQ(200,ACTBY,1)
  1. ..Q:ACTN="NOT GIVEN"
  1. ..Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
  1. ..S LSITE=$$LASTSITE^PSBINJEC(DFN,OI)
  1. ..S LIST(DTE)=DTE_U_ACTN_U_ORDN_U_LSITE_U_LOC_U_NURINI
  1. ..I ACTN="REMOVED" D
  1. ...S GIVE=$$FINDGIVE(IEN)
  1. ...S DATE=$P(GIVE,U)
  1. ...S NURINI=$P(GIVE,U,2)
  1. ...Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DATE,1)>MAX
  1. ...S LIST(DATE)=DATE_U_"GIVEN"_U_ORDN_U_LSITE_U_LOC_U_NURINI
  1. Q
  1. ;
  1. FIXADM ;Update ORD seg with GIVE status based on ALL ADM Records *83
  1. ; If any ADM's contain G then remove required for this ORDER
  1. N QQ,MRR,ADSTS,ADIEN,OIEN,RMTM
  1. S MRR=0,ADSTS=""
  1. F QQ=1:1:+$G(^TMP("PSB",$J,"CVRSHT",0)) D
  1. .Q:$E(^TMP("PSB",$J,"CVRSHT",QQ),1,3)="END"
  1. .I $E(^TMP("PSB",$J,"CVRSHT",QQ),1,3)="ORD" S OIEN=QQ,MRR=0 Q
  1. .I $E(^TMP("PSB",$J,"CVRSHT",QQ),1,2)="DD" D
  1. ..S MRR=$P(^TMP("PSB",$J,"CVRSHT",QQ),U,8)
  1. .;only update sts in ORD.14 if G found for any med
  1. .I $E(^TMP("PSB",$J,"CVRSHT",QQ),1,3)="ADM" D Q:ADSTS="G"
  1. ..S ADSTS=$P(^TMP("PSB",$J,"CVRSHT",QQ),U,5)
  1. ..S ADIEN=$P(^TMP("PSB",$J,"CVRSHT",QQ),U,4)
  1. ..S:ADIEN RMTM=$P(^PSB(53.79,ADIEN,.1),U,7)
  1. ..;if a Give & MRR med, then the Remove time needs to be retrieved
  1. ..;again from 53.79. The last info found by PSBVDLUD may not be for
  1. ..;this medlog record.
  1. ..D:ADSTS="G"&MRR
  1. ...S $P(^TMP("PSB",$J,"CVRSHT",OIEN),U,14)=ADSTS
  1. ...S $P(^TMP("PSB",$J,"CVRSHT",OIEN),U,36)=RMTM
  1. Q
  1. ;
  1. REMOVES(DFN,TYPE) ;Searches xrefs for MRR type meds needing removal and adds *83
  1. ;
  1. ;Type = (P)atient, (W)ard, (C)linic
  1. ;
  1. N PSBGNODE,PSBIEN,PSBZON,PSBRMDT,PSBMRRFL,PSBONX,PSBOITX,PSBOSP,PSBOSTS,DSPDRG
  1. ;
  1. ;Xref APATCH search (backwards compatible xref)
  1. S PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
  1. F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="APATCH")!($QS(PSBGNODE,3)'=DFN) D
  1. .S PSBIEN=$QS(PSBGNODE,5),PSBONX=$P(^PSB(53.79,PSBIEN,.1),U),DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
  1. .Q:'$D(^PSB(53.79,PSBIEN,.5,DSPDRG)) ;no disp drug
  1. .Q:$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH" ;not a Patch
  1. .Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G" ;not Given
  1. .S PSBRMDT=$P(^PSB(53.79,PSBIEN,.1),"^",7) Q:'PSBRMDT ;Scheduled Removal Time
  1. .Q:(PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
  1. .D PSJ1^PSBVT(DFN,PSBONX)
  1. .Q:(TYPE="C")&('PSBCLIEN) ;not a clinic order
  1. .D SETMRR
  1. ;
  1. ;Xref AMRR search (new xref for transdermal meds)
  1. S PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
  1. F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="AMRR")!($QS(PSBGNODE,3)'=DFN) D
  1. .S PSBIEN=$QS(PSBGNODE,5),PSBONX=$P(^PSB(53.79,PSBIEN,.1),U),DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
  1. .Q:$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)="PATCH" ;Is patch already seen
  1. .Q:'$D(^PSB(53.79,PSBIEN,.5,DSPDRG)) ;no disp drug
  1. .Q:'$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,6) ;no MRR flag
  1. .Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G" ;not Given
  1. .S PSBRMDT=$P(^PSB(53.79,PSBIEN,.1),"^",7) Q:'PSBRMDT ;Scheduled Removal Time
  1. .Q:(PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
  1. .D PSJ1^PSBVT(DFN,PSBONX)
  1. .Q:(TYPE="C")&('PSBCLIEN) ;not a clinic order
  1. .D SETMRR
  1. ;
  1. D CLEAN^PSBVT
  1. Q
  1. ;
  1. SETMRR ;Get and set MRR info for printing Removals
  1. ; If clinic order mode, skip removes for locations not on clinic list
  1. ; If No list then All clinics desired.
  1. N CLNAM S CLNAM=$P(^PSB(53.79,PSBIEN,0),U,2)
  1. I '$G(PSBIENS) N PSBIENS S PSBIENS=PSBRPT
  1. I PSBCLINORD,$D(^PSB(53.69,+PSBIENS,2,"B")),CLNAM]"",'$D(^PSB(53.69,+PSBIENS,2,"B",CLNAM)) Q ;not on selection list when list is present
  1. S PSBZON=$P(^PSB(53.79,PSBIEN,.1),"^")
  1. K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBZON,1)
  1. Q:$G(^TMP("PSJ1",$J,0))=-1
  1. S PSBONX=$P(^TMP("PSJ1",$J,0),U,3) ; ord num w/ type "U" or "V"
  1. S PSBOSTS=$P(^TMP("PSJ1",$J,1),U,10) ; ord status
  1. S PSBOITX=$P(^TMP("PSJ1",$J,2),U,2) ; order item (expanded)
  1. S PSBOSP=$P(^TMP("PSJ1",$J,4),U,7) ; stop date FM
  1. S ^TMP("PSB",$J,DFN,PSBRMDT,PSBOITX,PSBONX,"RM")=""
  1. S PSBS(DFN,PSBONX,$S(PSBOSTS="A":"Active",PSBOSTS="H":"On Hold",PSBOSTS="D":"DC'd",PSBOSTS="DE":"DC'd (Edit)",PSBOSTS="E":"Expired",PSBOSTS="O":"On Call",PSBOSTS="R":"Renewed",1:"*Unknown*"))="" ;PSB*3*76 adds Renewed as status
  1. S PSBSTXP(PSBONX,DFN,$$DTFMT^PSBOMM2(PSBOSP))=""
  1. Q