- PSBUTL ;BIRMINGHAM/EFC-BCMA UTILITIES ;03/06/16 3:06pm
- ;;3.0;BAR CODE MED ADMIN;**3,9,13,38,45,46,63,83,97,99,104,114**;Mar 2004;Build 3
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Reference/IA
- ; $$PATCH & $$VERSION^XPDUTL/10141
- ; File 50/221
- ; File 200/10060
- ; EN^PSJBCMA1/2829
- ;
- ;*83 - Add tags called by DD trigger xrefs
- ; - Add FIXADM to add to coversheet Results the G give action.
- ;
- DIWP(X,Y,PSB,PSBARGN) ;
- K ^UTILITY($J,"W")
- S DIWL=0,DIWR=Y,DIWF="C"_Y D ^DIWP
- F X=0:0 S X=$O(^UTILITY($J,"W",0,X)) Q:'X D
- .S Y=$O(@PSB@(""),-1)+1
- .; Naked Ref ^UTILITY($J,"W",0,X)
- .S @PSB@(Y)=$J("",+$G(PSBARGN))_^(X,0)
- S @PSB@(0)=+$O(@PSB@(""),-1)
- K ^UTILITY($J,"W"),DIWL,DIWR,DIWF
- Q
- ;
- SATURDAY(X,PSBDISP) ;
- S X=X\1 D H^%DTC ; Convert to $H
- S %H=%H+(6-%Y) ; Set it forward to Saturday
- D YMD^%DTC ; Back to FM Format
- 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)
- Q X
- ;
- SUNDAY(X,PSBDISP) ;
- S X=X\1 D H^%DTC ; Convert to $H
- S %H=%H-%Y ; Set it back to Sunday
- D YMD^%DTC ; Back to FM Format
- 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)
- Q X
- ;
- CLOCK(RESULTS,X) ; Verify Client/Server Date/Times are close enough
- ;
- ; RPC: PSB SERVER CLOCK VARIANCE
- ;
- ; Description:
- ; Returns variance from server to client in minutes
- ;
- N PSBCLNT,PSBSRVR,PSBDIFF,PSBMDNT
- S PSBMDNT=0
- 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
- S %DT="RS" D ^%DT S PSBCLNT=Y
- D NOW^%DTC S PSBSRVR=%
- 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
- S PSBDIFF=$$DIFF(PSBSRVR,PSBCLNT)
- S X=$$GET^XPAR("DIV","PSB SERVER CLOCK VARIANCE")
- I PSBDIFF>X!(PSBDIFF<(X*-1)) S RESULTS(0)="-1^"_PSBDIFF
- E S RESULTS(0)="1^"_PSBDIFF
- Q
- ;
- DIFF(X,X1) ; Difference in minutes between 2 FM dates
- ; Code copied from Fileman Function MINUTES
- 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
- Q X
- ;
- DRUGINQ ; Drug File Inquiry
- N PSBRET,PSBIEN,DIC,DIR,IOINORM,IOINHI
- S X="IOINHI;IOINORM" D ENDR^%ZISS
- S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- S DIC="^PSDRUG(",DIC(0)="AEQMVTN",DIC("T")="",D="B^C^VAPN^VAC^NDC^XATC",DIC("A")="Select DRUG: "
- ; Display active drugs and those for appl packages IV and Unit Dose
- 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"")"
- F W @IOF,!,"DRUG FILE INQUIRY",! D ^DIC Q:+Y<1 D
- .K PSBRET
- .S PSBIEN=+Y_","
- .D GETS^DIQ(50,PSBIEN,".01;16;25;51;215;213;101;9*","","PSBRET")
- .W @IOF,!,"DRUG NAME: ",IOINHI,PSBRET(50,PSBIEN,.01)
- .W " (IEN: ",+PSBIEN,")",IOINORM,!,$TR($J("",IOM)," ","-"),!
- .F X=16,25,51,215,213,101 D
- ..D FIELD^DID(50,X,"","LABEL","PSBRET")
- ..W !,PSBRET("LABEL"),":",?30,IOINHI
- ..D:$L(PSBRET(50,PSBIEN,X))>49
- ...F Y=1:1 Q:$L($P(PSBRET(50,PSBIEN,X)," ",1,Y))>49
- ...W $P(PSBRET(50,PSBIEN,X)," ",1,Y-1),!?30
- ...S PSBRET(50,PSBIEN,X)=$P(PSBRET(50,PSBIEN,X)," ",Y,250)
- ..W ?30,PSBRET(50,PSBIEN,X),IOINORM
- .W !!,"SYNONYMS:",IOINHI,!?15
- .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)
- .W IOINORM
- .F Q:$Y>(IOSL-3) W !
- .S DIR(0)="E" D ^DIR
- Q
- ;
- DPTSET ; Set Logic for pt-merge x-ref on patient field in file 53.79
- ;
- ; Entered Date/Time
- I $P(^PSB(53.79,DA,0),U,4) S ^PSB(53.79,"AEDT",X,$P(^PSB(53.79,DA,0),U,4),DA)=""
- ;
- ; Administration Date/Time
- D:$P(^PSB(53.79,DA,0),U,6)
- .S ^PSB(53.79,"AADT",X,$P(^PSB(53.79,DA,0),U,6),DA)=""
- .;
- .; Orderable Item + Administration Date/Time
- .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)=""
- ;
- ; PRN's by entered date/time
- 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)=""
- ;
- ; Order+Administration Date and Time
- 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)=""
- Q
- ;
- DPTKILL ; Kill Logic for pt-merge x-ref on patient field in file 53.79
- ;
- ; Entered Date/Time
- I $P(^PSB(53.79,DA,0),U,4) K ^PSB(53.79,"AEDT",X,$P(^PSB(53.79,DA,0),U,4),DA)
- ;
- ; Administration Date/Time
- D:$P(^PSB(53.79,DA,0),U,6)
- .K ^PSB(53.79,"AADT",X,$P(^PSB(53.79,DA,0),U,6),DA)
- .;
- .; Orderable Item + Administration Date/Time
- .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)
- ;
- ; PRN's by entered date/time
- 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)
- ;
- ; Order+Administration Date and Time
- 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)
- Q
- ;
- TIMEIN ;
- X ^%ZOSF("UPPERCASE") S X=Y
- I X="NOON" S X=.12 Q
- I X="MID" S X=.24 Q
- I (X="NOW")!(X="N") D NOW^%DTC S X=$E($P(%,".",2)_"0000",1,4)
- S X="T@"_X,%DT="R" D ^%DT
- I Y<1 K X Q
- S X=Y-DT
- Q
- ;
- TIMEOUT(X) ;
- N HOUR,MIN,AMPM
- S X=$E($P(X,".",2)_"0000",1,4)
- I X="2400" Q "12:00m"
- I X="1200" Q "12:00n"
- S HOUR=+$E(X,1,2),MIN=$E(X,3,4)
- S AMPM="a"
- S AMPM=$S(HOUR<12:"a",HOUR>11:"p",1:"**")
- S:HOUR>12 HOUR=HOUR-12
- Q HOUR_":"_MIN_AMPM
- ;
- HFSOPEN(HANDLE) ;
- N PSBDIR,PSBFILE
- S PSBDIR=$$DEFDIR^%ZISH()
- S PSBFILE="PSB"_DUZ_".DAT"
- D OPEN^%ZISH(HANDLE,PSBDIR,PSBFILE,"W") Q:POP
- S IOM=132,IOSL=99999,IOST="P-DUMMY",IOF=""""""
- Q
- ;
- HFSCLOSE(HANDLE) ;
- N PSBDIR,PSBFILE,PSBDEL
- D CLOSE^%ZISH(HANDLE)
- K ^TMP("PSBO",$J)
- S PSBDIR=$$DEFDIR^%ZISH()
- S PSBFILE="PSB"_DUZ_".DAT",PSBDEL(PSBFILE)=""
- S X=$$FTG^%ZISH(PSBDIR,PSBFILE,$NAME(^TMP("PSBO",$J,2)),3)
- S X=$$DEL^%ZISH(PSBDIR,$NA(PSBDEL))
- Q
- ;
- AUDIT(PSBREC,PSBDD,PSBFLD,PSBDATA,PSBSK) ; Med Log Audit
- ; used by cross references to 53.79 to track changes to fields in Med Log file
- ; xref AU05, AU06, AU09, AU16, AU21, AU22 pass the value 53.79 as PSBDD
- ; xref AU303, AU304 pass the value 53.795 as PSBDD
- ; xref AU603, AU604 pass the value 53.796 as PSBDD
- ; xref AU703, AU704 pass the value 53.797 as PSBDD
- ;
- N PSBDT,PSBTMP
- I '$D(PSBOLSTS) S PSBOLSTS=$P(^PSB(53.79,PSBREC,0),U,9)
- I '$D(PSBOLDUZ) S PSBOLDUZ=$P(^PSB(53.79,PSBREC,0),U,5)
- Q:$G(PSBDATA)=""!('$G(PSBAUDIT))
- D NOW^%DTC S PSBDT=%
- S PSBDATA=$$EXTERNAL^DILFD(PSBDD,PSBFLD,"",PSBDATA) ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
- D FIELD^DID(PSBDD,PSBFLD,"","LABEL","PSBTMP") ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
- S:'$D(^PSB(53.79,PSBREC,.9,0)) ^(0)="^53.799^^"
- S Y=$O(^PSB(53.79,PSBREC,.9,""),-1)+1,X=""
- I PSBTMP("LABEL")["ACTION STATUS" D Q
- .I PSBSK["K" S XY=Y F S XY=$O(^PSB(53.79,PSBREC,.9,XY),-1) Q:($D(PSBGOON))!(+XY'>0) D
- ..I ^PSB(53.79,PSBREC,.9,XY,0)["ACTION STATUS Set to '" D Q
- ...S PSBGOON=1,PSBOLDUZ=$P(^PSB(53.79,PSBREC,.9,XY,0),U,2),X=$P(^PSB(53.79,PSBREC,.9,XY,0),"'",2)
- .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)
- .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."
- .;PSB*3*45 Store Action status and last given fields.
- .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)
- I PSBSK["K" S ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" '"_PSBDATA_"' deleted."
- 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_"'."
- K XY,PSBGOON
- Q
- ;
- CHECK(RESULTS,PSBWHAT,PSBDATA) ; Checks for KIDS Patch or Build
- ; Module added in Patch PSB*1.0*3 DP/TOPEKA 22-DEC-1999 11:51:22
- ; PSBWHAT: B = Returns Build Version for packages by Namespace
- ; P = Returns if Patch is installed
- ; PSBDATA: Build/Package namespace (i.e. PSB) or Patch Number
- ; (i.e. PSB*1.0*1)
- ;
- S RESULTS(0)="-1^Unknown Parameter "_$G(PSBWHAT,"<PSBWHAT Undefined>")
- S PSBWHAT=$G(PSBWHAT),PSBDATA=$G(PSBDATA)
- D:PSBWHAT="B"
- .S X=$$VERSION^XPDUTL(PSBDATA)
- .S RESULTS(0)=$S(X="":"-1^Unknown Package/Build",1:"1^"_X)
- D:PSBWHAT="P"
- .S X=$$PATCH^XPDUTL(PSBDATA)
- .S RESULTS(0)=$S(X:"1^Patch Is Installed",1:"-1^Patch Is Not Installed")
- Q
- ;
- VERSION() ; [Extrinsic]
- ; Returns V#.# for display purposes
- Q "V"_$J(2,0,1)
- ;
- RESETADM ;
- ;
- ; This Subroutine will reset a medication order's resources
- ; based on Med Log New Entry or Edit Med Log activity.
- ;
- ; No input is necessary. Environment should be setup at call.
- ;
- Q:'$O(^PSB(53.79,0)) ;Quit if there are no BCMA entries, PSB*3*99
- 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
- .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)=""
- 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)
- I $G(PSBMMEN) I ($D(PSBWSID))&($G(Y(0))="SAVE") D
- .S:(PSBREC(3)="G") PSBFDAX(53.79,X,.26)=PSBWSID
- .S:$F("HR",PSBREC(3))>1 PSBFDAX(53.79,X,.26)=""
- .S X=$P(PSBIEN,"+1,",2)
- .D UPDATE^DIE("","PSBFDAX","X","PSBMSG")
- Q
- ;
- SCRNPTCH ;
- ;
- ; Maintain the "APATCH" index from SCREENMAN and Manual Med Entry.
- ;
- I Y(0)'="GIVEN" S PSBGPTCH=0 Q
- 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"
- Q:+PSBX=0
- S PSBGPTCH=1
- Q
- ;
- GIVEPTCH ;
- 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)
- .I $D(^PSB(53.79,"AORD",DFN,PSBONX,PSBX,DA)) D
- ..S PSBX=$P(^PSB(53.79,DA,0),U,6)
- ..I PSBGPTCH S ^PSB(53.79,"APATCH",DFN,PSBX,DA)="" K PSBX,PSBGPTCH Q
- ..I 'PSBGPTCH K ^PSB(53.79,"APATCH",DFN,PSBX,DA),PSBX,PSBGPTCH
- Q
- ;
- VALGIV() ;Validate Give, variance time set during a Trigger call *83
- Q:'$P($G(^PSB(53.79,DA,0)),U,6) 0
- Q ($P($G(^PSB(53.79,DA,.1)),U,2)="C"&($P($G(^(.1)),U,3)]"")&($G(PSBACTN)="G"))
- ;
- VALREM() ;Validate Remove, variance time set during a Trigger call *83
- Q:'$P($G(^PSB(53.79,DA,0)),U,6) 0
- Q ($P($G(^PSB(53.79,DA,.1)),U,2)="C"&($P($G(^(.1)),U,7)]"")&($G(PSBACTN)="RM"))
- ;
- REMSTR(A,D,TY,SP,PRSP) ;build remove time string from admin time string via DOA value *83
- ; A = admin time strg e.g. "0900-2100"
- ; D = Duration of Admin (DOA)
- ; TY = sched type
- ; SP = order stop date
- ; PRSP = previous stop date
- ;
- N RMTM,RMSTR,Q
- S RMSTR="",TY=$G(TY),SP=$G(SP),PRSP=$G(PRSP)
- ;
- ;no admin time, return null RMSTR
- Q:(TY'="O")&('A) RMSTR
- ;
- ;sched typ is One Time, return Ord stop time as RMSTR
- I TY="O" D Q RMSTR
- .S RMSTR=$S(PRSP:PRSP,1:SP),RMSTR=$E($P(RMSTR,".",2)_"0000",1,4)
- ;
- ;continuous schedules with valid admin times
- F Q=1:1:$L(A,"-") D
- .S RMTM=DT_"."_$P(A,"-",Q)
- .S RMTM=$$FMADD^XLFDT(RMTM,,,D)
- .S RMTM=$P(RMTM,".",2),RMTM=$E(RMTM_"0000",1,4)
- .S $P(RMSTR,"-",Q)=RMTM
- Q RMSTR
- ;
- CNVRT4(STR,SEP) ;Converts a time string to 4 digit for consistency *83
- ; STR - string of times
- ; SEP - separator character between times
- ;
- N QQ
- F QQ=1:1:$L(STR,SEP) S $P(STR,SEP,QQ)=$E($P(STR,SEP,QQ)_"0000",1,4)
- Q STR
- ;
- FINDGIVE(IEN) ;Finds the last Give date/time in the Audit log for a RM sts *83
- ; When a Remove action occurs and saved to 53.79, the Give Action
- ; Status & Action Date/Time are overwritten. This Function will
- ; retrieve that Give info.
- ;
- ; Function returns - string formatted as the MAH report uses:
- ;
- ; date/time^by initials^action code^IEN of #53.79^IEN of user #200
- ;
- Q:$P(^PSB(53.79,IEN,0),U,9)'="RM" ""
- N DA,DAT,GIVE,FOUND,STR,QQ,PRVDA,PRVDAT,SKIP
- S (FOUND,STR,GIVE)=""
- F DA=99999:0 S DA=$O(^PSB(53.79,IEN,.9,DA),-1) Q:'DA D Q:FOUND
- .S DAT=^PSB(53.79,IEN,.9,DA,0),SKIP=0
- .; check for previous audit to be an Undo RM, if so skip it
- .I DAT["ACTION STATUS Set to 'GIVEN'" D Q
- ..S PRVDA=$O(^PSB(53.79,IEN,.9,DA),-1) ;previous audit DA
- ..D:PRVDA
- ...S PRVDAT=^PSB(53.79,IEN,.9,PRVDA,0)
- ...I PRVDAT["ACTION STATUS 'REMOVED'",PRVDAT["deleted" S SKIP=1
- ..Q:SKIP
- ..S $P(STR,U,1)=$P(DAT,U,1) ;init date just in case
- ..S $P(STR,U,2)=$P(DAT,"'",4) ;by initials
- ..S $P(STR,U,3)="G" ;action sts Give
- ..S $P(STR,U,4)=IEN ;ien of transaction
- ..S $P(STR,U,5)=$P(DAT,U,2) ;ien of user file 200
- ..S GIVE=1
- .Q:SKIP
- .;
- .;preferred date of action is in external form, as manual med edits
- .;can be back dated and show up here vs audit date/time for the Give
- .D:GIVE
- ..Q:DAT'["DATE/TIME Set to"
- ..S:DAT?.E1"@".E $P(STR,U,1)=$$ETFM($P(^(0),"'",2))
- ..;found real date
- ..S FOUND=1
- Q STR
- ;
- ETFM(EX) ;convert external to FM date format
- N M,MM,MTH,TM,DY,Y,Y1,Y2,YYY,YYYY,Q
- S MTH=$E(EX,1,3)
- S Q=0
- F M="JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC" S Q=Q+.01,MM(M)=Q
- S MM=$E($P(MM(MTH),".",2)_"0",1,2)
- ;
- S DY=$P(EX," ",2),DY=$TR(DY,",","")
- S Y=$P(EX," ",3),YYYY=$P(Y,"@"),Y1=$E(YYYY,1,2)-17,Y2=$E(YYYY,3,4),YYYY=Y1_Y2
- S TM=$P(Y,"@",2),TM=$TR(TM,":","")
- Q $E(YYYY_MM_DY_"."_TM,1,12)
- ;
- MEDHIST(LIST,DFN,OI,MAX) ;Last nn admin actions per a patients Orderable Item
- ;
- ; Reference/IA
- ; #6271 for Inpatient Medications to call into BCMA *83
- ; ** NOTE **
- ; THIS API IS DIRECTLY/INDIRECTLY DEPENDANT ON 3 OTHER INTERNAL
- ; API's: LASTSITE^PSBINJEC, RPC^PSBVDLUD, & FINDGIVE^PSBUTL
- ;
- ; Input:
- ; DFN - Patient num
- ; OI - Inpatient Meds Orderable Item ien
- ; MAX - Max days back to search
- ; Output:
- ; LIST - Array of actions formatted as :
- ; DATE^ACTION^ORDNO^LSTSITE^LOCATION^NURSINITL
- ;
- K LIST
- N DTE,CNT,IEN,ACTN,GIVE,DATE,LSITE,ACTBY,NURINI,ORDN,LOC
- ;
- S DTE=DT+1
- F S DTE=$O(^PSB(53.79,"AOIP",DFN,OI,DTE),-1) Q:'DTE D Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
- .S IEN=0
- .F S IEN=$O(^PSB(53.79,"AOIP",DFN,OI,DTE,IEN)) Q:'IEN D Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
- ..S ACTN=$$GET1^DIQ(53.79,IEN,.09)
- ..S ORDN=$$GET1^DIQ(53.79,IEN,.11)
- ..S LOC=$$GET1^DIQ(53.79,IEN,.02)
- ..S ACTBY=$$GET1^DIQ(53.79,IEN,.07,"I")
- ..S NURINI=$$GET1^DIQ(200,ACTBY,1)
- ..Q:ACTN="NOT GIVEN"
- ..Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
- ..S LSITE=$$LASTSITE^PSBINJEC(DFN,OI)
- ..S LIST(DTE)=DTE_U_ACTN_U_ORDN_U_LSITE_U_LOC_U_NURINI
- ..I ACTN="REMOVED" D
- ...S GIVE=$$FINDGIVE(IEN)
- ...S DATE=$P(GIVE,U)
- ...S NURINI=$P(GIVE,U,2)
- ...Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DATE,1)>MAX
- ...S LIST(DATE)=DATE_U_"GIVEN"_U_ORDN_U_LSITE_U_LOC_U_NURINI
- Q
- ;
- FIXADM ;Update ORD seg with GIVE status based on ALL ADM Records *83
- ; If any ADM's contain G then remove required for this ORDER
- N QQ,MRR,ADSTS,ADIEN,OIEN,RMTM
- S MRR=0,ADSTS=""
- F QQ=1:1:+$G(^TMP("PSB",$J,"CVRSHT",0)) D
- .Q:$E(^TMP("PSB",$J,"CVRSHT",QQ),1,3)="END"
- .I $E(^TMP("PSB",$J,"CVRSHT",QQ),1,3)="ORD" S OIEN=QQ,MRR=0 Q
- .I $E(^TMP("PSB",$J,"CVRSHT",QQ),1,2)="DD" D
- ..S MRR=$P(^TMP("PSB",$J,"CVRSHT",QQ),U,8)
- .;only update sts in ORD.14 if G found for any med
- .I $E(^TMP("PSB",$J,"CVRSHT",QQ),1,3)="ADM" D Q:ADSTS="G"
- ..S ADSTS=$P(^TMP("PSB",$J,"CVRSHT",QQ),U,5)
- ..S ADIEN=$P(^TMP("PSB",$J,"CVRSHT",QQ),U,4)
- ..S:ADIEN RMTM=$P(^PSB(53.79,ADIEN,.1),U,7)
- ..;if a Give & MRR med, then the Remove time needs to be retrieved
- ..;again from 53.79. The last info found by PSBVDLUD may not be for
- ..;this medlog record.
- ..D:ADSTS="G"&MRR
- ...S $P(^TMP("PSB",$J,"CVRSHT",OIEN),U,14)=ADSTS
- ...S $P(^TMP("PSB",$J,"CVRSHT",OIEN),U,36)=RMTM
- Q
- ;
- REMOVES(DFN,TYPE) ;Searches xrefs for MRR type meds needing removal and adds *83
- ;
- ;Type = (P)atient, (W)ard, (C)linic
- ;
- N PSBGNODE,PSBIEN,PSBZON,PSBRMDT,PSBMRRFL,PSBONX,PSBOITX,PSBOSP,PSBOSTS,DSPDRG
- ;
- ;Xref APATCH search (backwards compatible xref)
- S PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
- F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="APATCH")!($QS(PSBGNODE,3)'=DFN) D
- .S PSBIEN=$QS(PSBGNODE,5),PSBONX=$P(^PSB(53.79,PSBIEN,.1),U),DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
- .Q:'$D(^PSB(53.79,PSBIEN,.5,DSPDRG)) ;no disp drug
- .Q:$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH" ;not a Patch
- .Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G" ;not Given
- .S PSBRMDT=$P(^PSB(53.79,PSBIEN,.1),"^",7) Q:'PSBRMDT ;Scheduled Removal Time
- .Q:(PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
- .D PSJ1^PSBVT(DFN,PSBONX)
- .Q:(TYPE="C")&('PSBCLIEN) ;not a clinic order
- .D SETMRR
- ;
- ;Xref AMRR search (new xref for transdermal meds)
- S PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
- F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="AMRR")!($QS(PSBGNODE,3)'=DFN) D
- .S PSBIEN=$QS(PSBGNODE,5),PSBONX=$P(^PSB(53.79,PSBIEN,.1),U),DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
- .Q:$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)="PATCH" ;Is patch already seen
- .Q:'$D(^PSB(53.79,PSBIEN,.5,DSPDRG)) ;no disp drug
- .Q:'$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,6) ;no MRR flag
- .Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G" ;not Given
- .S PSBRMDT=$P(^PSB(53.79,PSBIEN,.1),"^",7) Q:'PSBRMDT ;Scheduled Removal Time
- .Q:(PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
- .D PSJ1^PSBVT(DFN,PSBONX)
- .Q:(TYPE="C")&('PSBCLIEN) ;not a clinic order
- .D SETMRR
- ;
- D CLEAN^PSBVT
- Q
- ;
- SETMRR ;Get and set MRR info for printing Removals
- ; If clinic order mode, skip removes for locations not on clinic list
- ; If No list then All clinics desired.
- N CLNAM S CLNAM=$P(^PSB(53.79,PSBIEN,0),U,2)
- I '$G(PSBIENS) N PSBIENS S PSBIENS=PSBRPT
- 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
- S PSBZON=$P(^PSB(53.79,PSBIEN,.1),"^")
- K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBZON,1)
- Q:$G(^TMP("PSJ1",$J,0))=-1
- S PSBONX=$P(^TMP("PSJ1",$J,0),U,3) ; ord num w/ type "U" or "V"
- S PSBOSTS=$P(^TMP("PSJ1",$J,1),U,10) ; ord status
- S PSBOITX=$P(^TMP("PSJ1",$J,2),U,2) ; order item (expanded)
- S PSBOSP=$P(^TMP("PSJ1",$J,4),U,7) ; stop date FM
- S ^TMP("PSB",$J,DFN,PSBRMDT,PSBOITX,PSBONX,"RM")=""
- 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
- S PSBSTXP(PSBONX,DFN,$$DTFMT^PSBOMM2(PSBOSP))=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBUTL 19323 printed Jan 18, 2025@02:42:28 Page 2
- 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
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Reference/IA
- +5 ; $$PATCH & $$VERSION^XPDUTL/10141
- +6 ; File 50/221
- +7 ; File 200/10060
- +8 ; EN^PSJBCMA1/2829
- +9 ;
- +10 ;*83 - Add tags called by DD trigger xrefs
- +11 ; - Add FIXADM to add to coversheet Results the G give action.
- +12 ;
- DIWP(X,Y,PSB,PSBARGN) ;
- +1 KILL ^UTILITY($JOB,"W")
- +2 SET DIWL=0
- SET DIWR=Y
- SET DIWF="C"_Y
- DO ^DIWP
- +3 FOR X=0:0
- SET X=$ORDER(^UTILITY($JOB,"W",0,X))
- if 'X
- QUIT
- Begin DoDot:1
- +4 SET Y=$ORDER(@PSB@(""),-1)+1
- +5 ; Naked Ref ^UTILITY($J,"W",0,X)
- +6 SET @PSB@(Y)=$JUSTIFY("",+$GET(PSBARGN))_^(X,0)
- End DoDot:1
- +7 SET @PSB@(0)=+$ORDER(@PSB@(""),-1)
- +8 KILL ^UTILITY($JOB,"W"),DIWL,DIWR,DIWF
- +9 QUIT
- +10 ;
- SATURDAY(X,PSBDISP) ;
- +1 ; Convert to $H
- SET X=X\1
- DO H^%DTC
- +2 ; Set it forward to Saturday
- SET %H=%H+(6-%Y)
- +3 ; Back to FM Format
- DO YMD^%DTC
- +4 IF $GET(PSBDISP)
- SET PSBDISP=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
- DO EN^DDIOL("Actual date is Saturday "_PSBDISP)
- +5 QUIT X
- +6 ;
- SUNDAY(X,PSBDISP) ;
- +1 ; Convert to $H
- SET X=X\1
- DO H^%DTC
- +2 ; Set it back to Sunday
- SET %H=%H-%Y
- +3 ; Back to FM Format
- DO YMD^%DTC
- +4 IF $GET(PSBDISP)
- SET PSBDISP=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
- DO EN^DDIOL("Actual date is Sunday "_PSBDISP)
- +5 QUIT X
- +6 ;
- CLOCK(RESULTS,X) ; Verify Client/Server Date/Times are close enough
- +1 ;
- +2 ; RPC: PSB SERVER CLOCK VARIANCE
- +3 ;
- +4 ; Description:
- +5 ; Returns variance from server to client in minutes
- +6 ;
- +7 NEW PSBCLNT,PSBSRVR,PSBDIFF,PSBMDNT
- +8 SET PSBMDNT=0
- +9 ;Change Delphi time for midnight from 0000 to 2400 in PSB*3.0*63
- IF $PIECE(X,"@",2)="0000"
- SET $PIECE(X,"@",2)="2400"
- SET PSBMDNT=1
- +10 SET %DT="RS"
- DO ^%DT
- SET PSBCLNT=Y
- +11 DO NOW^%DTC
- SET PSBSRVR=%
- +12 ;Change Delphi date for midnight from day following midnight to day previous to midnight in PSB*3.0*63
- if $GET(PSBMDNT)
- SET PSBCLNT=$$FMADD^XLFDT(PSBCLNT,-1,0,0,0)
- +13 SET PSBDIFF=$$DIFF(PSBSRVR,PSBCLNT)
- +14 SET X=$$GET^XPAR("DIV","PSB SERVER CLOCK VARIANCE")
- +15 IF PSBDIFF>X!(PSBDIFF<(X*-1))
- SET RESULTS(0)="-1^"_PSBDIFF
- +16 IF '$TEST
- SET RESULTS(0)="1^"_PSBDIFF
- +17 QUIT
- +18 ;
- DIFF(X,X1) ; Difference in minutes between 2 FM dates
- +1 ; Code copied from Fileman Function MINUTES
- +2 SET Y=$EXTRACT(X1_"000",9,10)-$EXTRACT(X_"000",9,10)*60+$EXTRACT(X1_"00000",11,12)-$EXTRACT(X_"00000",11,12)
- SET X2=X
- SET X=$PIECE(X,".",1)'=$PIECE(X1,".",1)
- if X
- DO ^%DTC
- SET X=X*1440+Y
- +3 QUIT X
- +4 ;
- DRUGINQ ; Drug File Inquiry
- +1 NEW PSBRET,PSBIEN,DIC,DIR,IOINORM,IOINHI
- +2 SET X="IOINHI;IOINORM"
- DO ENDR^%ZISS
- +3 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- +4 SET DIC="^PSDRUG("
- SET DIC(0)="AEQMVTN"
- SET DIC("T")=""
- SET D="B^C^VAPN^VAC^NDC^XATC"
- SET DIC("A")="Select DRUG: "
- +5 ; Display active drugs and those for appl packages IV and Unit Dose
- +6 SET 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"")"
- +7 FOR
- WRITE @IOF,!,"DRUG FILE INQUIRY",!
- DO ^DIC
- if +Y<1
- QUIT
- Begin DoDot:1
- +8 KILL PSBRET
- +9 SET PSBIEN=+Y_","
- +10 DO GETS^DIQ(50,PSBIEN,".01;16;25;51;215;213;101;9*","","PSBRET")
- +11 WRITE @IOF,!,"DRUG NAME: ",IOINHI,PSBRET(50,PSBIEN,.01)
- +12 WRITE " (IEN: ",+PSBIEN,")",IOINORM,!,$TRANSLATE($JUSTIFY("",IOM)," ","-"),!
- +13 FOR X=16,25,51,215,213,101
- Begin DoDot:2
- +14 DO FIELD^DID(50,X,"","LABEL","PSBRET")
- +15 WRITE !,PSBRET("LABEL"),":",?30,IOINHI
- +16 if $LENGTH(PSBRET(50,PSBIEN,X))>49
- Begin DoDot:3
- +17 FOR Y=1:1
- if $LENGTH($PIECE(PSBRET(50,PSBIEN,X)," ",1,Y))>49
- QUIT
- +18 WRITE $PIECE(PSBRET(50,PSBIEN,X)," ",1,Y-1),!?30
- +19 SET PSBRET(50,PSBIEN,X)=$PIECE(PSBRET(50,PSBIEN,X)," ",Y,250)
- End DoDot:3
- +20 WRITE ?30,PSBRET(50,PSBIEN,X),IOINORM
- End DoDot:2
- +21 WRITE !!,"SYNONYMS:",IOINHI,!?15
- +22 SET X=""
- FOR
- SET X=$ORDER(PSBRET(50.1,X))
- if X=""
- QUIT
- if $X>40
- WRITE !?15
- if $X>15
- WRITE ?40
- WRITE PSBRET(50.1,X,.01)
- +23 WRITE IOINORM
- +24 FOR
- if $Y>(IOSL-3)
- QUIT
- WRITE !
- +25 SET DIR(0)="E"
- DO ^DIR
- End DoDot:1
- +26 QUIT
- +27 ;
- DPTSET ; Set Logic for pt-merge x-ref on patient field in file 53.79
- +1 ;
- +2 ; Entered Date/Time
- +3 IF $PIECE(^PSB(53.79,DA,0),U,4)
- SET ^PSB(53.79,"AEDT",X,$PIECE(^PSB(53.79,DA,0),U,4),DA)=""
- +4 ;
- +5 ; Administration Date/Time
- +6 if $PIECE(^PSB(53.79,DA,0),U,6)
- Begin DoDot:1
- +7 SET ^PSB(53.79,"AADT",X,$PIECE(^PSB(53.79,DA,0),U,6),DA)=""
- +8 ;
- +9 ; Orderable Item + Administration Date/Time
- +10 IF $PIECE(^PSB(53.79,DA,0),U,8)
- SET ^PSB(53.79,"AOIP",X,$PIECE(^PSB(53.79,DA,0),U,8),$PIECE(^PSB(53.79,DA,0),U,6),DA)=""
- End DoDot:1
- +11 ;
- +12 ; PRN's by entered date/time
- +13 IF $PIECE($GET(^PSB(53.79,DA,.1)),U,2)="P"&($PIECE(^(0),U,4))
- SET ^PSB(53.79,"APRN",X,$PIECE(^PSB(53.79,DA,0),U,4),DA)=""
- +14 ;
- +15 ; Order+Administration Date and Time
- +16 IF $PIECE($GET(^PSB(53.79,DA,.1)),U)]""&($PIECE($GET(^PSB(53.79,DA,.1)),U,3))
- SET ^PSB(53.79,"AORD",X,$PIECE(^PSB(53.79,DA,.1),U),$PIECE(^PSB(53.79,DA,.1),U,3),DA)=""
- +17 QUIT
- +18 ;
- DPTKILL ; Kill Logic for pt-merge x-ref on patient field in file 53.79
- +1 ;
- +2 ; Entered Date/Time
- +3 IF $PIECE(^PSB(53.79,DA,0),U,4)
- KILL ^PSB(53.79,"AEDT",X,$PIECE(^PSB(53.79,DA,0),U,4),DA)
- +4 ;
- +5 ; Administration Date/Time
- +6 if $PIECE(^PSB(53.79,DA,0),U,6)
- Begin DoDot:1
- +7 KILL ^PSB(53.79,"AADT",X,$PIECE(^PSB(53.79,DA,0),U,6),DA)
- +8 ;
- +9 ; Orderable Item + Administration Date/Time
- +10 IF $PIECE(^PSB(53.79,DA,0),U,8)
- KILL ^PSB(53.79,"AOIP",X,$PIECE(^PSB(53.79,DA,0),U,8),$PIECE(^PSB(53.79,DA,0),U,6),DA)
- End DoDot:1
- +11 ;
- +12 ; PRN's by entered date/time
- +13 IF $PIECE($GET(^PSB(53.79,DA,.1)),U,2)="P"&($PIECE(^(0),U,4))
- KILL ^PSB(53.79,"APRN",X,$PIECE(^PSB(53.79,DA,0),U,4),DA)
- +14 ;
- +15 ; Order+Administration Date and Time
- +16 IF $PIECE($GET(^PSB(53.79,DA,.1)),U)]""&($PIECE($GET(^PSB(53.79,DA,.1)),U,3))
- KILL ^PSB(53.79,"AORD",X,$PIECE(^PSB(53.79,DA,.1),U),$PIECE(^PSB(53.79,DA,.1),U,3),DA)
- +17 QUIT
- +18 ;
- TIMEIN ;
- +1 XECUTE ^%ZOSF("UPPERCASE")
- SET X=Y
- +2 IF X="NOON"
- SET X=.12
- QUIT
- +3 IF X="MID"
- SET X=.24
- QUIT
- +4 IF (X="NOW")!(X="N")
- DO NOW^%DTC
- SET X=$EXTRACT($PIECE(%,".",2)_"0000",1,4)
- +5 SET X="T@"_X
- SET %DT="R"
- DO ^%DT
- +6 IF Y<1
- KILL X
- QUIT
- +7 SET X=Y-DT
- +8 QUIT
- +9 ;
- TIMEOUT(X) ;
- +1 NEW HOUR,MIN,AMPM
- +2 SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
- +3 IF X="2400"
- QUIT "12:00m"
- +4 IF X="1200"
- QUIT "12:00n"
- +5 SET HOUR=+$EXTRACT(X,1,2)
- SET MIN=$EXTRACT(X,3,4)
- +6 SET AMPM="a"
- +7 SET AMPM=$SELECT(HOUR<12:"a",HOUR>11:"p",1:"**")
- +8 if HOUR>12
- SET HOUR=HOUR-12
- +9 QUIT HOUR_":"_MIN_AMPM
- +10 ;
- HFSOPEN(HANDLE) ;
- +1 NEW PSBDIR,PSBFILE
- +2 SET PSBDIR=$$DEFDIR^%ZISH()
- +3 SET PSBFILE="PSB"_DUZ_".DAT"
- +4 DO OPEN^%ZISH(HANDLE,PSBDIR,PSBFILE,"W")
- if POP
- QUIT
- +5 SET IOM=132
- SET IOSL=99999
- SET IOST="P-DUMMY"
- SET IOF=""""""
- +6 QUIT
- +7 ;
- HFSCLOSE(HANDLE) ;
- +1 NEW PSBDIR,PSBFILE,PSBDEL
- +2 DO CLOSE^%ZISH(HANDLE)
- +3 KILL ^TMP("PSBO",$JOB)
- +4 SET PSBDIR=$$DEFDIR^%ZISH()
- +5 SET PSBFILE="PSB"_DUZ_".DAT"
- SET PSBDEL(PSBFILE)=""
- +6 SET X=$$FTG^%ZISH(PSBDIR,PSBFILE,$NAME(^TMP("PSBO",$JOB,2)),3)
- +7 SET X=$$DEL^%ZISH(PSBDIR,$NAME(PSBDEL))
- +8 QUIT
- +9 ;
- 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
- +2 ; xref AU05, AU06, AU09, AU16, AU21, AU22 pass the value 53.79 as PSBDD
- +3 ; xref AU303, AU304 pass the value 53.795 as PSBDD
- +4 ; xref AU603, AU604 pass the value 53.796 as PSBDD
- +5 ; xref AU703, AU704 pass the value 53.797 as PSBDD
- +6 ;
- +7 NEW PSBDT,PSBTMP
- +8 IF '$DATA(PSBOLSTS)
- SET PSBOLSTS=$PIECE(^PSB(53.79,PSBREC,0),U,9)
- +9 IF '$DATA(PSBOLDUZ)
- SET PSBOLDUZ=$PIECE(^PSB(53.79,PSBREC,0),U,5)
- +10 if $GET(PSBDATA)=""!('$GET(PSBAUDIT))
- QUIT
- +11 DO NOW^%DTC
- SET PSBDT=%
- +12 ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
- SET PSBDATA=$$EXTERNAL^DILFD(PSBDD,PSBFLD,"",PSBDATA)
- +13 ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
- DO FIELD^DID(PSBDD,PSBFLD,"","LABEL","PSBTMP")
- +14 if '$DATA(^PSB(53.79,PSBREC,.9,0))
- SET ^(0)="^53.799^^"
- +15 SET Y=$ORDER(^PSB(53.79,PSBREC,.9,""),-1)+1
- SET X=""
- +16 IF PSBTMP("LABEL")["ACTION STATUS"
- Begin DoDot:1
- +17 IF PSBSK["K"
- SET XY=Y
- FOR
- SET XY=$ORDER(^PSB(53.79,PSBREC,.9,XY),-1)
- if ($DATA(PSBGOON))!(+XY'>0)
- QUIT
- Begin DoDot:2
- +18 IF ^PSB(53.79,PSBREC,.9,XY,0)["ACTION STATUS Set to '"
- Begin DoDot:3
- +19 SET PSBGOON=1
- SET PSBOLDUZ=$PIECE(^PSB(53.79,PSBREC,.9,XY,0),U,2)
- SET X=$PIECE(^PSB(53.79,PSBREC,.9,XY,0),"'",2)
- End DoDot:3
- QUIT
- End DoDot:2
- +20 if $LENGTH(X)'>2
- SET X=PSBOLSTS
- SET X=$SELECT(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)
- +21 IF PSBSK["K"
- SET ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" '"_PSBDATA_"' by '"_$$GET1^DIQ(200,PSBOLDUZ,"INITIAL")_"' deleted."
- +22 ;PSB*3*45 Store Action status and last given fields.
- +23 IF '$TEST
- SET ^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_$PIECE(^PSB(53.79,PSBREC,0),"^",7)
- End DoDot:1
- QUIT
- +24 IF PSBSK["K"
- SET ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" '"_PSBDATA_"' deleted."
- +25 IF '$TEST
- SET ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_$SELECT(PSBTMP("LABEL")["DISPENSE DRUG":" Added '",1:" Set to '")_PSBDATA_"'."
- +26 KILL XY,PSBGOON
- +27 QUIT
- +28 ;
- 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
- +2 ; PSBWHAT: B = Returns Build Version for packages by Namespace
- +3 ; P = Returns if Patch is installed
- +4 ; PSBDATA: Build/Package namespace (i.e. PSB) or Patch Number
- +5 ; (i.e. PSB*1.0*1)
- +6 ;
- +7 SET RESULTS(0)="-1^Unknown Parameter "_$GET(PSBWHAT,"<PSBWHAT Undefined>")
- +8 SET PSBWHAT=$GET(PSBWHAT)
- SET PSBDATA=$GET(PSBDATA)
- +9 if PSBWHAT="B"
- Begin DoDot:1
- +10 SET X=$$VERSION^XPDUTL(PSBDATA)
- +11 SET RESULTS(0)=$SELECT(X="":"-1^Unknown Package/Build",1:"1^"_X)
- End DoDot:1
- +12 if PSBWHAT="P"
- Begin DoDot:1
- +13 SET X=$$PATCH^XPDUTL(PSBDATA)
- +14 SET RESULTS(0)=$SELECT(X:"1^Patch Is Installed",1:"-1^Patch Is Not Installed")
- End DoDot:1
- +15 QUIT
- +16 ;
- VERSION() ; [Extrinsic]
- +1 ; Returns V#.# for display purposes
- +2 QUIT "V"_$JUSTIFY(2,0,1)
- +3 ;
- RESETADM ;
- +1 ;
- +2 ; This Subroutine will reset a medication order's resources
- +3 ; based on Med Log New Entry or Edit Med Log activity.
- +4 ;
- +5 ; No input is necessary. Environment should be setup at call.
- +6 ;
- +7 ;Quit if there are no BCMA entries, PSB*3*99
- if '$ORDER(^PSB(53.79,0))
- QUIT
- +8 IF '$GET(PSBMMEN)
- SET X=$SELECT($PIECE(PSBIEN,",",2)]"":$PIECE(PSBIEN,",",2),1:+PSBIEN)
- DO CLEAN^PSBVT
- DO PSJ1^PSBVT($PIECE(^PSB(53.79,X,0),U),$PIECE(^PSB(53.79,X,.1),U))
- if ($$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$GET(PSBIVPSH)))
- Begin DoDot:1
- +9 SET X=PSBIEN
- SET X2=X_$SELECT(X="+1":",",1:"")
- if '$DATA(PSBFDA(53.79,X2,.09))
- QUIT
- IF $FIND("HR",PSBFDA(53.79,X2,.09))>1
- SET PSBFDA(53.79,X2,.26)=""
- End DoDot:1
- DO CLEAN^PSBVT
- +10 IF $GET(PSBMMEN)
- IF PSBIEN="+1"
- IF $GET(PSBONX)["V"
- SET PSBWSID=PSBFDA(53.79,"+1,",.26)
- KILL PSBFDA(53.79,"+1,",.26),PSBFDA(53.79,"+1,",.09)
- +11 IF $GET(PSBMMEN)
- IF ($DATA(PSBWSID))&($GET(Y(0))="SAVE")
- Begin DoDot:1
- +12 if (PSBREC(3)="G")
- SET PSBFDAX(53.79,X,.26)=PSBWSID
- +13 if $FIND("HR",PSBREC(3))>1
- SET PSBFDAX(53.79,X,.26)=""
- +14 SET X=$PIECE(PSBIEN,"+1,",2)
- +15 DO UPDATE^DIE("","PSBFDAX","X","PSBMSG")
- End DoDot:1
- +16 QUIT
- +17 ;
- SCRNPTCH ;
- +1 ;
- +2 ; Maintain the "APATCH" index from SCREENMAN and Manual Med Entry.
- +3 ;
- +4 IF Y(0)'="GIVEN"
- SET PSBGPTCH=0
- QUIT
- +5 SET PSBX=0
- FOR
- SET PSBX=$ORDER(^PSB(53.79,DA,.5,PSBX))
- if +PSBX=0
- QUIT
- if $PIECE(^PSB(53.79,DA,.5,+PSBX,0),U,4)="PATCH"
- QUIT
- +6 if +PSBX=0
- QUIT
- +7 SET PSBGPTCH=1
- +8 QUIT
- +9 ;
- GIVEPTCH ;
- +1 IF $DATA(^PSB(53.79,"AORD",DFN,PSBONX))
- NEW PSBX
- SET PSBX=""
- FOR
- SET PSBX=$ORDER(^PSB(53.79,"AORD",DFN,PSBONX,PSBX))
- if +PSBX=0
- QUIT
- if $DATA(^PSB(53.79,"AORD",DFN,PSBONX,PSBX,DA))
- Begin DoDot:1
- +2 IF $DATA(^PSB(53.79,"AORD",DFN,PSBONX,PSBX,DA))
- Begin DoDot:2
- +3 SET PSBX=$PIECE(^PSB(53.79,DA,0),U,6)
- +4 IF PSBGPTCH
- SET ^PSB(53.79,"APATCH",DFN,PSBX,DA)=""
- KILL PSBX,PSBGPTCH
- QUIT
- +5 IF 'PSBGPTCH
- KILL ^PSB(53.79,"APATCH",DFN,PSBX,DA),PSBX,PSBGPTCH
- End DoDot:2
- End DoDot:1
- if '$DATA(PSBX)
- QUIT
- +6 QUIT
- +7 ;
- VALGIV() ;Validate Give, variance time set during a Trigger call *83
- +1 if '$PIECE($GET(^PSB(53.79,DA,0)),U,6)
- QUIT 0
- +2 QUIT ($PIECE($GET(^PSB(53.79,DA,.1)),U,2)="C"&($PIECE($GET(^(.1)),U,3)]"")&($GET(PSBACTN)="G"))
- +3 ;
- VALREM() ;Validate Remove, variance time set during a Trigger call *83
- +1 if '$PIECE($GET(^PSB(53.79,DA,0)),U,6)
- QUIT 0
- +2 QUIT ($PIECE($GET(^PSB(53.79,DA,.1)),U,2)="C"&($PIECE($GET(^(.1)),U,7)]"")&($GET(PSBACTN)="RM"))
- +3 ;
- 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"
- +2 ; D = Duration of Admin (DOA)
- +3 ; TY = sched type
- +4 ; SP = order stop date
- +5 ; PRSP = previous stop date
- +6 ;
- +7 NEW RMTM,RMSTR,Q
- +8 SET RMSTR=""
- SET TY=$GET(TY)
- SET SP=$GET(SP)
- SET PRSP=$GET(PRSP)
- +9 ;
- +10 ;no admin time, return null RMSTR
- +11 if (TY'="O")&('A)
- QUIT RMSTR
- +12 ;
- +13 ;sched typ is One Time, return Ord stop time as RMSTR
- +14 IF TY="O"
- Begin DoDot:1
- +15 SET RMSTR=$SELECT(PRSP:PRSP,1:SP)
- SET RMSTR=$EXTRACT($PIECE(RMSTR,".",2)_"0000",1,4)
- End DoDot:1
- QUIT RMSTR
- +16 ;
- +17 ;continuous schedules with valid admin times
- +18 FOR Q=1:1:$LENGTH(A,"-")
- Begin DoDot:1
- +19 SET RMTM=DT_"."_$PIECE(A,"-",Q)
- +20 SET RMTM=$$FMADD^XLFDT(RMTM,,,D)
- +21 SET RMTM=$PIECE(RMTM,".",2)
- SET RMTM=$EXTRACT(RMTM_"0000",1,4)
- +22 SET $PIECE(RMSTR,"-",Q)=RMTM
- End DoDot:1
- +23 QUIT RMSTR
- +24 ;
- CNVRT4(STR,SEP) ;Converts a time string to 4 digit for consistency *83
- +1 ; STR - string of times
- +2 ; SEP - separator character between times
- +3 ;
- +4 NEW QQ
- +5 FOR QQ=1:1:$LENGTH(STR,SEP)
- SET $PIECE(STR,SEP,QQ)=$EXTRACT($PIECE(STR,SEP,QQ)_"0000",1,4)
- +6 QUIT STR
- +7 ;
- 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
- +2 ; Status & Action Date/Time are overwritten. This Function will
- +3 ; retrieve that Give info.
- +4 ;
- +5 ; Function returns - string formatted as the MAH report uses:
- +6 ;
- +7 ; date/time^by initials^action code^IEN of #53.79^IEN of user #200
- +8 ;
- +9 if $PIECE(^PSB(53.79,IEN,0),U,9)'="RM"
- QUIT ""
- +10 NEW DA,DAT,GIVE,FOUND,STR,QQ,PRVDA,PRVDAT,SKIP
- +11 SET (FOUND,STR,GIVE)=""
- +12 FOR DA=99999:0
- SET DA=$ORDER(^PSB(53.79,IEN,.9,DA),-1)
- if 'DA
- QUIT
- Begin DoDot:1
- +13 SET DAT=^PSB(53.79,IEN,.9,DA,0)
- SET SKIP=0
- +14 ; check for previous audit to be an Undo RM, if so skip it
- +15 IF DAT["ACTION STATUS Set to 'GIVEN'"
- Begin DoDot:2
- +16 ;previous audit DA
- SET PRVDA=$ORDER(^PSB(53.79,IEN,.9,DA),-1)
- +17 if PRVDA
- Begin DoDot:3
- +18 SET PRVDAT=^PSB(53.79,IEN,.9,PRVDA,0)
- +19 IF PRVDAT["ACTION STATUS 'REMOVED'"
- IF PRVDAT["deleted"
- SET SKIP=1
- End DoDot:3
- +20 if SKIP
- QUIT
- +21 ;init date just in case
- SET $PIECE(STR,U,1)=$PIECE(DAT,U,1)
- +22 ;by initials
- SET $PIECE(STR,U,2)=$PIECE(DAT,"'",4)
- +23 ;action sts Give
- SET $PIECE(STR,U,3)="G"
- +24 ;ien of transaction
- SET $PIECE(STR,U,4)=IEN
- +25 ;ien of user file 200
- SET $PIECE(STR,U,5)=$PIECE(DAT,U,2)
- +26 SET GIVE=1
- End DoDot:2
- QUIT
- +27 if SKIP
- QUIT
- +28 ;
- +29 ;preferred date of action is in external form, as manual med edits
- +30 ;can be back dated and show up here vs audit date/time for the Give
- +31 if GIVE
- Begin DoDot:2
- +32 if DAT'["DATE/TIME Set to"
- QUIT
- +33 if DAT?.E1"@".E
- SET $PIECE(STR,U,1)=$$ETFM($PIECE(^(0),"'",2))
- +34 ;found real date
- +35 SET FOUND=1
- End DoDot:2
- End DoDot:1
- if FOUND
- QUIT
- +36 QUIT STR
- +37 ;
- ETFM(EX) ;convert external to FM date format
- +1 NEW M,MM,MTH,TM,DY,Y,Y1,Y2,YYY,YYYY,Q
- +2 SET MTH=$EXTRACT(EX,1,3)
- +3 SET Q=0
- +4 FOR M="JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC"
- SET Q=Q+.01
- SET MM(M)=Q
- +5 SET MM=$EXTRACT($PIECE(MM(MTH),".",2)_"0",1,2)
- +6 ;
- +7 SET DY=$PIECE(EX," ",2)
- SET DY=$TRANSLATE(DY,",","")
- +8 SET Y=$PIECE(EX," ",3)
- SET YYYY=$PIECE(Y,"@")
- SET Y1=$EXTRACT(YYYY,1,2)-17
- SET Y2=$EXTRACT(YYYY,3,4)
- SET YYYY=Y1_Y2
- +9 SET TM=$PIECE(Y,"@",2)
- SET TM=$TRANSLATE(TM,":","")
- +10 QUIT $EXTRACT(YYYY_MM_DY_"."_TM,1,12)
- +11 ;
- MEDHIST(LIST,DFN,OI,MAX) ;Last nn admin actions per a patients Orderable Item
- +1 ;
- +2 ; Reference/IA
- +3 ; #6271 for Inpatient Medications to call into BCMA *83
- +4 ; ** NOTE **
- +5 ; THIS API IS DIRECTLY/INDIRECTLY DEPENDANT ON 3 OTHER INTERNAL
- +6 ; API's: LASTSITE^PSBINJEC, RPC^PSBVDLUD, & FINDGIVE^PSBUTL
- +7 ;
- +8 ; Input:
- +9 ; DFN - Patient num
- +10 ; OI - Inpatient Meds Orderable Item ien
- +11 ; MAX - Max days back to search
- +12 ; Output:
- +13 ; LIST - Array of actions formatted as :
- +14 ; DATE^ACTION^ORDNO^LSTSITE^LOCATION^NURSINITL
- +15 ;
- +16 KILL LIST
- +17 NEW DTE,CNT,IEN,ACTN,GIVE,DATE,LSITE,ACTBY,NURINI,ORDN,LOC
- +18 ;
- +19 SET DTE=DT+1
- +20 FOR
- SET DTE=$ORDER(^PSB(53.79,"AOIP",DFN,OI,DTE),-1)
- if 'DTE
- QUIT
- Begin DoDot:1
- +21 SET IEN=0
- +22 FOR
- SET IEN=$ORDER(^PSB(53.79,"AOIP",DFN,OI,DTE,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +23 SET ACTN=$$GET1^DIQ(53.79,IEN,.09)
- +24 SET ORDN=$$GET1^DIQ(53.79,IEN,.11)
- +25 SET LOC=$$GET1^DIQ(53.79,IEN,.02)
- +26 SET ACTBY=$$GET1^DIQ(53.79,IEN,.07,"I")
- +27 SET NURINI=$$GET1^DIQ(200,ACTBY,1)
- +28 if ACTN="NOT GIVEN"
- QUIT
- +29 if $$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
- QUIT
- +30 SET LSITE=$$LASTSITE^PSBINJEC(DFN,OI)
- +31 SET LIST(DTE)=DTE_U_ACTN_U_ORDN_U_LSITE_U_LOC_U_NURINI
- +32 IF ACTN="REMOVED"
- Begin DoDot:3
- +33 SET GIVE=$$FINDGIVE(IEN)
- +34 SET DATE=$PIECE(GIVE,U)
- +35 SET NURINI=$PIECE(GIVE,U,2)
- +36 if $$FMDIFF^XLFDT($$NOW^XLFDT,DATE,1)>MAX
- QUIT
- +37 SET LIST(DATE)=DATE_U_"GIVEN"_U_ORDN_U_LSITE_U_LOC_U_NURINI
- End DoDot:3
- End DoDot:2
- if $$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
- QUIT
- End DoDot:1
- if $$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
- QUIT
- +38 QUIT
- +39 ;
- 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
- +2 NEW QQ,MRR,ADSTS,ADIEN,OIEN,RMTM
- +3 SET MRR=0
- SET ADSTS=""
- +4 FOR QQ=1:1:+$GET(^TMP("PSB",$JOB,"CVRSHT",0))
- Begin DoDot:1
- +5 if $EXTRACT(^TMP("PSB",$JOB,"CVRSHT",QQ),1,3)="END"
- QUIT
- +6 IF $EXTRACT(^TMP("PSB",$JOB,"CVRSHT",QQ),1,3)="ORD"
- SET OIEN=QQ
- SET MRR=0
- QUIT
- +7 IF $EXTRACT(^TMP("PSB",$JOB,"CVRSHT",QQ),1,2)="DD"
- Begin DoDot:2
- +8 SET MRR=$PIECE(^TMP("PSB",$JOB,"CVRSHT",QQ),U,8)
- End DoDot:2
- +9 ;only update sts in ORD.14 if G found for any med
- +10 IF $EXTRACT(^TMP("PSB",$JOB,"CVRSHT",QQ),1,3)="ADM"
- Begin DoDot:2
- +11 SET ADSTS=$PIECE(^TMP("PSB",$JOB,"CVRSHT",QQ),U,5)
- +12 SET ADIEN=$PIECE(^TMP("PSB",$JOB,"CVRSHT",QQ),U,4)
- +13 if ADIEN
- SET RMTM=$PIECE(^PSB(53.79,ADIEN,.1),U,7)
- +14 ;if a Give & MRR med, then the Remove time needs to be retrieved
- +15 ;again from 53.79. The last info found by PSBVDLUD may not be for
- +16 ;this medlog record.
- +17 if ADSTS="G"&MRR
- Begin DoDot:3
- +18 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT",OIEN),U,14)=ADSTS
- +19 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT",OIEN),U,36)=RMTM
- End DoDot:3
- End DoDot:2
- if ADSTS="G"
- QUIT
- End DoDot:1
- +20 QUIT
- +21 ;
- REMOVES(DFN,TYPE) ;Searches xrefs for MRR type meds needing removal and adds *83
- +1 ;
- +2 ;Type = (P)atient, (W)ard, (C)linic
- +3 ;
- +4 NEW PSBGNODE,PSBIEN,PSBZON,PSBRMDT,PSBMRRFL,PSBONX,PSBOITX,PSBOSP,PSBOSTS,DSPDRG
- +5 ;
- +6 ;Xref APATCH search (backwards compatible xref)
- +7 SET PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
- +8 FOR
- SET PSBGNODE=$QUERY(@PSBGNODE)
- if PSBGNODE']""
- QUIT
- if ($QSUBSCRIPT(PSBGNODE,2)'="APATCH")!($QSUBSCRIPT(PSBGNODE,3)'=DFN)
- QUIT
- Begin DoDot:1
- +9 SET PSBIEN=$QSUBSCRIPT(PSBGNODE,5)
- SET PSBONX=$PIECE(^PSB(53.79,PSBIEN,.1),U)
- SET DSPDRG=$ORDER(^PSB(53.79,PSBIEN,.5,0))
- IF 'DSPDRG
- QUIT
- +10 ;no disp drug
- if '$DATA(^PSB(53.79,PSBIEN,.5,DSPDRG))
- QUIT
- +11 ;not a Patch
- if $PIECE(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH"
- QUIT
- +12 ;not Given
- if $PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G"
- QUIT
- +13 ;Scheduled Removal Time
- SET PSBRMDT=$PIECE(^PSB(53.79,PSBIEN,.1),"^",7)
- if 'PSBRMDT
- QUIT
- +14 if (PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
- QUIT
- +15 DO PSJ1^PSBVT(DFN,PSBONX)
- +16 ;not a clinic order
- if (TYPE="C")&('PSBCLIEN)
- QUIT
- +17 DO SETMRR
- End DoDot:1
- +18 ;
- +19 ;Xref AMRR search (new xref for transdermal meds)
- +20 SET PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
- +21 FOR
- SET PSBGNODE=$QUERY(@PSBGNODE)
- if PSBGNODE']""
- QUIT
- if ($QSUBSCRIPT(PSBGNODE,2)'="AMRR")!($QSUBSCRIPT(PSBGNODE,3)'=DFN)
- QUIT
- Begin DoDot:1
- +22 SET PSBIEN=$QSUBSCRIPT(PSBGNODE,5)
- SET PSBONX=$PIECE(^PSB(53.79,PSBIEN,.1),U)
- SET DSPDRG=$ORDER(^PSB(53.79,PSBIEN,.5,0))
- IF 'DSPDRG
- QUIT
- +23 ;Is patch already seen
- if $PIECE(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)="PATCH"
- QUIT
- +24 ;no disp drug
- if '$DATA(^PSB(53.79,PSBIEN,.5,DSPDRG))
- QUIT
- +25 ;no MRR flag
- if '$PIECE(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,6)
- QUIT
- +26 ;not Given
- if $PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G"
- QUIT
- +27 ;Scheduled Removal Time
- SET PSBRMDT=$PIECE(^PSB(53.79,PSBIEN,.1),"^",7)
- if 'PSBRMDT
- QUIT
- +28 if (PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
- QUIT
- +29 DO PSJ1^PSBVT(DFN,PSBONX)
- +30 ;not a clinic order
- if (TYPE="C")&('PSBCLIEN)
- QUIT
- +31 DO SETMRR
- End DoDot:1
- +32 ;
- +33 DO CLEAN^PSBVT
- +34 QUIT
- +35 ;
- SETMRR ;Get and set MRR info for printing Removals
- +1 ; If clinic order mode, skip removes for locations not on clinic list
- +2 ; If No list then All clinics desired.
- +3 NEW CLNAM
- SET CLNAM=$PIECE(^PSB(53.79,PSBIEN,0),U,2)
- +4 IF '$GET(PSBIENS)
- NEW PSBIENS
- SET PSBIENS=PSBRPT
- +5 ;not on selection list when list is present
- IF PSBCLINORD
- IF $DATA(^PSB(53.69,+PSBIENS,2,"B"))
- IF CLNAM]""
- IF '$DATA(^PSB(53.69,+PSBIENS,2,"B",CLNAM))
- QUIT
- +6 SET PSBZON=$PIECE(^PSB(53.79,PSBIEN,.1),"^")
- +7 KILL ^TMP("PSJ1",$JOB)
- DO EN^PSJBCMA1(DFN,PSBZON,1)
- +8 if $GET(^TMP("PSJ1",$JOB,0))=-1
- QUIT
- +9 ; ord num w/ type "U" or "V"
- SET PSBONX=$PIECE(^TMP("PSJ1",$JOB,0),U,3)
- +10 ; ord status
- SET PSBOSTS=$PIECE(^TMP("PSJ1",$JOB,1),U,10)
- +11 ; order item (expanded)
- SET PSBOITX=$PIECE(^TMP("PSJ1",$JOB,2),U,2)
- +12 ; stop date FM
- SET PSBOSP=$PIECE(^TMP("PSJ1",$JOB,4),U,7)
- +13 SET ^TMP("PSB",$JOB,DFN,PSBRMDT,PSBOITX,PSBONX,"RM")=""
- +14 ;PSB*3*76 adds Renewed as status
- SET PSBS(DFN,PSBONX,$SELECT(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*"))=""
- +15 SET PSBSTXP(PSBONX,DFN,$$DTFMT^PSBOMM2(PSBOSP))=""
- +16 QUIT