ORFIMM1 ;SLC/AGP - GENERIC EDIT IMMUNIZATION CONT ;May 18, 2023@16:45:03
;;3.0;ORDER ENTRY/RESULTS REPORTING;**405,597,588**;Dec 17, 1997;Build 29
;
; Reference to IMMGRP^PXAPIIM in ICR #6387
; Reference to IMMROUTE^PXVRPC2 in ICR #7283
; Reference to GETUNITS^PXVRPC4 in ICR #7284
; Reference to ARTAPI^PXVUTIL in ICR #7398
;
Q
;
BLD(RESULTS,LIST,INPUTS) ;
N ADMINDATE,CAT,CNT,DATE,EXT,HASERR,ID,IDX,IMNAME,INT,MSG,NAME,NODE,NOTEARR,NOTEINP,PARM,PARR,PRMPTS,VIS,VISCNT
N PIECE,X,DELSTR,DELSTR1,DELSTR2,DELSTR3
N LOC,DATETIME,ENCTYPE,TYPE,VISITSTR,ORLOT
;
S ID=$G(INPUTS("ID")),IMNAME=$G(INPUTS("NAME"))
S TYPE=$G(INPUTS("DOCUMENTTYPE"))
S VISITSTR=$G(INPUTS("VISITSTR"))
S LOC=$P(VISITSTR,";"),DATETIME=$P(VISITSTR,";",2),ENCTYPE=$P(VISITSTR,";",3)
;
S DELSTR=$S(TYPE=2:"ICR+"_U_U_U_U,TYPE=3:"ICR+"_U_U_U_U,1:"IMM+"_U_ID_U_U_IMNAME)
S DELSTR1="COM"_U_1_U_"@",$P(DELSTR,U,$S(TYPE=5:29,1:10))=1
I TYPE'=5 S DELSTR2="COM"_U_2_U_"@",$P(DELSTR,U,24)=2
S HASERR=0,CNT=0
;
D BLDPRMPT^ORFEDT(.PRMPTS)
D BLDPARR^ORFEDT(.PARR)
;
S VISCNT=0,VIS=""
S IDX=0 F S IDX=$O(LIST(IDX)) Q:IDX'>0!(HASERR=1) D
.S NODE=LIST(IDX)
.S NAME=$P(NODE,U),INT=$P(NODE,U,2),EXT=$P(NODE,U,3)
.S PARM=$G(PARR(NAME))
.I PARM?1(1"pnumComment",1"pnumImmOverride"),$L(NODE,"^")>3 D Q
..S RESULTS(CNT)="-1^"_$S(PARM="pnumImmOverride":"Override Reason",1:"Comment")_" cannot contain a caret symbol"
..S HASERR=1
.I PARM="pnumIMMVIS" D Q
..I VIS="" S VIS=INT_"/"_$P(ADMINDATE,".") Q
..I VIS'="" S VIS=VIS_";"_INT_"/"_$P(ADMINDATE,".")
.;
.I PARM="pnumAdminDate" D Q
..S PIECE=+$G(PRMPTS(PARM))
..I INT>$$GETMAXDT() D Q ; don't allow future admin/read times (unless over the dateline, allow up to T+1@23:59)
...S RESULTS(CNT)="-1^"_$S(TYPE=5:"Read",1:"Administration")_" Date"_$S(TYPE=1:"",1:"/Time")_" cannot be a future date"_$S(TYPE=1:"",1:"/Time")_"."
...S HASERR=1
..S ADMINDATE=INT
..S $P(DELSTR,U,$S(TYPE=5:27,1:PIECE))=INT
.;
.I PARM="pnumImmLot" D
..I TYPE=1 S INT=""
..I TYPE=0 S ORLOT=INT
.I PARM="" Q
.S PIECE=+$G(PRMPTS(PARM)) I PIECE=0 Q
.D BLDSTRS(.RESULTS,.CNT,PARM,TYPE,EXT,INT,PIECE,ID,IMNAME,LOC,.DELSTR,.DELSTR1,.DELSTR2,.MSG)
.I $P($G(RESULTS(CNT)),U)=-1 S HASERR=1
;
I TYPE=0,$G(ORLOT)="",'HASERR D
.S RESULTS(CNT)="-1^Lot Number is required."
.S HASERR=1
;
I HASERR=1 Q
S CNT=0
S $P(DELSTR,U,PRMPTS("pnumIMMVIS"))=VIS
I TYPE=0 S $P(DELSTR,U,12)="00"
S RESULTS(CNT)=1_U_$S(+$G(ADMINDATE)>0:ADMINDATE,1:DATETIME)
D GETTEXT(.NOTEARR,.LIST,ID,IMNAME,TYPE,DATETIME,LOC,0)
;
S IDX=0 F S IDX=$O(NOTEARR(IDX)) Q:IDX'>0 S CNT=CNT+1,RESULTS(CNT)="NOTE"_U_NOTEARR(IDX)
S CNT=CNT+1,RESULTS(CNT)="DATA"_U_DELSTR
S CNT=CNT+1,RESULTS(CNT)="DATA1"_U_$G(DELSTR1)
S CNT=CNT+1,RESULTS(CNT)="DATA2"_U_$G(DELSTR2)
S IDX=0 F S IDX=$O(MSG(IDX)) Q:IDX'>0 S CNT=CNT+1,RESULTS(CNT)="MSG"_U_MSG(IDX)
Q
;
BLDSTRS(RESULT,CNT,PARM,TYPE,EXT,INT,PIECE,ID,NAME,LOC,DELSTR,DELSTR1,DELSTR2,MSG) ;
N IDX,TEMP
I PARM?1(1"pnumAdminByPolicy",1"pnumImmOrderByIEN",1"pnumImmSite",1"pnumImmSeries",1"pnumWarnDate") D
. I INT="" S INT="@"
I PARM="pnumDataSource" S $P(DELSTR,U,PIECE)=EXT_";"_INT Q
I PARM="pnumImmDosage" D DOSECHK(.RESULT,.CNT,.DELSTR,INT,ID,LOC,PIECE) Q
I PARM="pnumImmRoute" S $P(DELSTR,U,PIECE)=EXT_";;"_INT Q
I PARM="pnumImmSite" D Q
.D CHK^DIE(9000010.11,1303,,$$TRIM^XLFSTR(EXT),.TEMP)
.I TEMP="^",(EXT'=""!(INT=-1)),INT'="@" S RESULT(CNT)="-1^Anatomic Location is not a valid selection" Q
.S $P(DELSTR,U,PIECE)=EXT_";;"_INT Q
I PARM="pnumImmLot" S $P(DELSTR,U,PIECE)=EXT_";"_INT Q
I PARM="pnumImmManufacturer" S $P(DELSTR,U,PIECE)=EXT Q
I PARM="pnumExpirationDate" S $P(DELSTR,U,PIECE)=$S(EXT:$$FMTE^XLFDT(EXT,"2D"),1:EXT) Q
I PARM="pnumImmOrderByIEN" D
.S $P(DELSTR,U,PIECE)=INT
.I INT=""!(INT="@") S $P(DELSTR,U,31)=1
.I INT>0 S $P(DELSTR,U,31)="@"
I PARM="pnumImmSeries" D Q
.S TEMP=$$EXTERNAL^DILFD(9000010.11,.04,,INT)
.I TEMP="",(EXT'=""!(INT=-1)),INT'="@" S RESULT(CNT)="-1^Series is not a valid selection" Q
.S $P(DELSTR,U,PIECE)=INT Q
I PARM="pnumProvider" S $P(DELSTR,U,$S(TYPE=5:28,1:PIECE))=INT Q
I PARM="pnumComment",EXT'="" D Q
.I $L(EXT)>245 S RESULT(CNT)="-1^Comment cannot exceed 245 characters" Q
.S DELSTR1="COM"_U_1_U_EXT
I PARM="pnumImmOverride",EXT'="" D Q
.I $L(EXT)>245 S RESULT(CNT)="-1^Override Reason cannot exceed 245 characters" Q
.S $P(DELSTR,U,23)=1,DELSTR2="COM"_U_2_U_EXT
I PARM="pnumDataSource" S $P(DELSTR,U,PIECE)=";"_INT Q
I PARM="pnumImmContra" D Q
.S $P(DELSTR,U,2)=INT_";PXV(920.4,",$P(DELSTR,U,4)=EXT,$P(DELSTR,U,5)=ID_";"_NAME
.I $$ARTAPI^PXVUTIL(INT)>0 D
..S IDX=$O(MSG(""),-1)
..I IDX>0 S IDX=IDX+1,MSG(IDX)=" "
..S IDX=IDX+1,MSG(IDX)="You are recording an allergy/adverse reaction contraindication reason. This"
..S IDX=IDX+1,MSG(IDX)="information should also be recorded in the Adverse Reaction Tracking package"
..S IDX=IDX+1,MSG(IDX)="if it is not already present there."
I PARM="pnumWarnDate" D Q
.I +INT>0,INT<$$NOW^XLFDT() S RESULT(CNT)="-1^Choose reschedule date cannot be in the past."
.S $P(DELSTR,U,PIECE)=INT
I PARM="pnumImmRefused" S $P(DELSTR,U,2)=INT_";PXV(920.5,",$P(DELSTR,U,4)=EXT,$P(DELSTR,U,5)=ID_";"_NAME Q
I PARM="pnumSkinResults" S $P(DELSTR,U,25)=INT Q
I PARM="pnumSkinReading" S $P(DELSTR,U,26)=EXT Q
I PARM="pnumReadingIEN" S $P(DELSTR,U,30)=INT Q
I PARM="pnumRefusedGroup" S $P(DELSTR,U,9)=$S(INT=1:0,1:1)
Q
;
DOSECHK(RESULT,CNT,DELSTR,INT,ID,LOC,PIECE) ;
N TEMP
I INT="" Q
S INT=$$TRIM^XLFSTR(INT,"LR")
;check for any alpha characters
I INT?.E1A.E S RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits." Q
;check for any punctuation characters beside a period
S TEMP=$TR(INT,".","") I TEMP?.E1P.E S RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits." Q
;check for control characters
I INT?.E1C.E S RESULT(CNT)="-1^Incorrect format for dose. Cannot contains a control character" Q
I INT["." D Q
.S TEMP=$P(INT,".",2) I $L(TEMP)>2 S RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits." Q
.S TEMP=$P(INT,".") I (TEMP>999)!(TEMP<0) S RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits." Q
.S TEMP=$$GETUNITS^PXVRPC4(ID,LOC)
.S $P(DELSTR,U,PIECE)=INT_";"_$P(TEMP,U,2)
I (INT>999)!(INT<0) S RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits." Q
K TEMP S TEMP=$$GETUNITS^PXVRPC4(ID,LOC)
S $P(DELSTR,U,PIECE)=INT_";"_$P(TEMP,U,2)
Q
;
;
GETROUTE(RESULT,CNT,DEFAULT,LOCLIST) ;
N DEF,DATALST,ISLOC,X
S DEF=+$G(DEFAULT("ADMIN ROUTE"))
D IMMROUTE^PXVRPC2(.DATALST,"S:A",1)
S ISLOC=0
S X=0 F S X=$O(DATALST(X)) Q:X'>0 D
.I DATALST(X)'[U Q
.I DEF>0,+$P(DATALST(X),U)>0,DEF=+$P(DATALST(X),U) S ISLOC=1
.I DEF>0,+$P(DATALST(X),U)>0,DEF'=+$P(DATALST(X),U) S ISLOC=0
.I ISLOC,$P(DATALST(X),U)="SITE" S LOCLIST($P(DATALST(X),U,2))=""
.S CNT=CNT+1,RESULT(CNT)="DATA"_U_"ADMIN ROUTE"_U_DATALST(X)
Q
;
GETSTOP(RESULT,CNT,DEFAULTS,ID,DATETIME,ENCTYPE) ;
S CNT=CNT+1,RESULT(CNT)="DATA"_U_"STOP"_U_0_U_"No"
S CNT=CNT+1,RESULT(CNT)="DATA"_U_"STOP"_U_1_U_"Yes, this will stop the forecasting reminders of future doses"
Q
;
GETTEXT(OUTPUT,LIST,ID,IMMNAME,TYPE,DATETIME,LOC,FORMAT) ;
;scheduling ICR 10040
N I,J,DIV,NODE,ORGRPS,TEMP,TEMPARR,XLOC,VISCNT
I FORMAT=0 D BLDDEFLS^ORFEDT(.LIST,.TEMPARR)
I FORMAT=1 M TEMPARR=LIST
S I=0
I TYPE=2!(TYPE=3) D Q
.D FORMAT(.OUTPUT,.I,IMMNAME,"Immunization: ")
.I TYPE=2 D FORMAT(.OUTPUT,.I,$P(TEMPARR("CONTRAINDICATED"),U,2),"Contraindication/Precaution Reason: ")
.I TYPE=3 S I=I+1,OUTPUT(I)="Refusal Reason: "_$P(TEMPARR("REFUSAL"),U,2)
.I $P($G(TEMPARR("STOP")),U)=1 S I=I+1,OUTPUT(I)="Cancel Series and stop forecasting: Yes"
.I $P($G(TEMPARR("WARN")),U,2)'="" S I=I+1,OUTPUT(I)="Warn Until: "_$TR($$FMTE^XLFDT($P(TEMPARR("WARN"),U,2),"2ZM"),"@"," ")
.I TYPE=3,$P($G(TEMPARR("CVXONLY")),U)'="" D
..I +$P($G(TEMPARR("CVXONLY")),U)=0 D Q
...D IMMGRP^PXAPIIM(.ORGRPS,ID)
...S TEMP=$O(ORGRPS("VG",""))
...D FORMAT(.OUTPUT,.I,$S(TEMP'="":"Patient refuses all immunization(s) in the "_TEMP_" group",1:"Patient refuses all immunization(s) in the group"))
..D FORMAT(.OUTPUT,.I,"Patient refuses the "_IMMNAME_" immunization")
.I $P($G(TEMPARR("COMMENTS")),U,2)'="" D FORMAT(.OUTPUT,.I,$P(TEMPARR("COMMENTS"),U,2),"Comment: ")
.S I=I+1,OUTPUT(I)="Date Documented: "_$TR($$FMTE^XLFDT($$NOW^XLFDT,"2ZM"),"@"," ")
;
S TEMP=$S(TYPE=0:"Administered",TYPE=1:"Documented",TYPE=2:"Contraindicated/Precaution",TYPE=3:"Refusal",TYPE=5:"Read",1:"")
D FORMAT(.OUTPUT,.I,IMMNAME,TEMP_": ")
S TEMP=$S(TYPE=1:"Historical Date Administered",TYPE=5:"Date Read",1:"Date Administered")_": "
I TYPE=1 D
.S TEMP=TEMP_$$FMTE^XLFDT($P($G(TEMPARR("VISIT DATE TIME")),U,2),1)
.I $E($P($G(TEMPARR("VISIT DATE TIME")),U,2),4,5)="00" S TEMP=TEMP_" Exact date unknown" Q
.I $E($P($G(TEMPARR("VISIT DATE TIME")),U,2),6,7)="00" S TEMP=TEMP_" Exact date unknown" Q
I TYPE'=1 S TEMP=TEMP_$TR($$FMTE^XLFDT($P($G(TEMPARR("VISIT DATE TIME")),U,2),1),"@"," ")
;determine label depending on admin vs historical
S I=I+1,OUTPUT(I)=$$LJ^XLFSTR(TEMP,50)
I $P($G(TEMPARR("SERIES")),U,2)'="" S OUTPUT(I)=OUTPUT(I)_$$LJ^XLFSTR("Series: "_$P(TEMPARR("SERIES"),U,2),50)
I $P($G(TEMPARR("MANUFACTURER")),U,2)'="" D FORMAT(.OUTPUT,.I,$P(TEMPARR("MANUFACTURER"),U,2),"Manufacturer: ")
S:$P($G(TEMPARR("LOT NUMBER")),U,2)'="" I=I+1,OUTPUT(I)=$$LJ^XLFSTR("Lot: "_$P(TEMPARR("LOT NUMBER"),U,2),50)_"Exp Date: "_$S($P($G(TEMPARR("EXPIRATION DATE")),U,2)'="":$$FMTE^XLFDT($P(TEMPARR("EXPIRATION DATE"),U,2),"1D"),1:"Unknown")
S:$P($G(TEMPARR("LOT NUMBER")),U,7)'="" I=I+1,OUTPUT(I)=$$LJ^XLFSTR("NDC: "_$P(TEMPARR("LOT NUMBER"),U,7),50)
;
;determine label depending on admin vs historical
I +LOC=LOC S LOC=$$GET1^DIQ(44,LOC,.01)
S XLOC=""
I TYPE=1 S TEMP="Outside Location: " S XLOC=$P(TEMPARR("LOCATION"),U,2)
;I TYPE=0 S TEMP="Location: ",XLOC=LOC
S TEMP=TEMP_XLOC
I XLOC'="" S I=I+1,OUTPUT(I)=$$LJ^XLFSTR(TEMP,60)
;
S:$P($G(TEMPARR("ADMIN ROUTE")),U,2)'="" I=I+1,OUTPUT(I)="Admin Route/Site: "_$P(TEMPARR("ADMIN ROUTE"),U,2)_"/"_$P($G(TEMPARR("ADMIN SITE")),U,2)
I $P($G(TEMPARR("DOSE")),U,2)'="" D
.S DIV=$S(+$P($G(^SC(+LOC,0)),U,15)>0:+$P($G(^SC(+LOC,0)),U,15),1:DUZ(2))
.S TEMP=$$GETUNITS^PXVRPC4(ID,DIV)
.S I=I+1,OUTPUT(I)="Dosage: "_$P(TEMPARR("DOSE"),U,2)_$S($P(TEMP,U,2)'="":$P(TEMP,U,2),$P(TEMP,U,3)'="":$P(TEMP,U,3),1:"")
S:$P($G(TEMPARR("INFO SOURCE")),U,2)'="" I=I+1,OUTPUT(I)="Information Source: "_$P(TEMPARR("INFO SOURCE"),U,2)
;
I $D(TEMPARR("VIS OFFERED")) D
.S I=I+1,OUTPUT(I)="Vaccine Information Statement(s):"
.I $D(TEMPARR("VIS OFFERED"))=1 D FORMAT(.OUTPUT,.I,$P($P(TEMPARR("VIS OFFERED"),U,2),";")," ") Q
.S VISCNT=0 F S VISCNT=$O(TEMPARR("VIS OFFERED",VISCNT)) Q:VISCNT'>0 D
..D FORMAT(.OUTPUT,.I,$P($P(TEMPARR("VIS OFFERED",VISCNT),U,2),";")," ")
I TYPE=0 S I=I+1,OUTPUT(I)="Order By: "_$S($P($G(TEMPARR("ORDERING PROVIDER")),U,2)'="":$P(TEMPARR("ORDERING PROVIDER"),U,2),1:"Policy")
I $P($G(TEMPARR("ENCOUNTER PROVIDER")),U,2)'="" D
.S I=I+1,OUTPUT(I)=$S(TYPE=5:"Read By:",TYPE=0:"Administered By: ",1:"Documented By: ")_$P(TEMPARR("ENCOUNTER PROVIDER"),U,2)
I $P($G(TEMPARR("COMMENTS")),U,2)'="" D FORMAT(.OUTPUT,.I,$P(TEMPARR("COMMENTS"),U,2),"Comment: ")
I $P($G(TEMPARR("OVERRIDE REASON")),U,2)'="" D FORMAT(.OUTPUT,.I,$P(TEMPARR("OVERRIDE REASON"),U,2),"Override Reason: ")
I $P($G(TEMPARR("PLACEMENT IEN")),U,2)'="" S I=I+1,OUTPUT(I)="Measurements: "_$P($G(TEMPARR("READING")),U,2)
I $P($G(TEMPARR("RESULTS")),U,2)'="" S I=I+1,OUTPUT(I)="Interpretation: "_$P($G(TEMPARR("RESULTS")),U,2)
S I=I+1,OUTPUT(I)=" "
Q
;
FORMAT(OROUTPUT,ORLINE,ORTEXT,ORTITLE) ;
N DIWL,DIWR,DIWF,X,ORX,ORINDENT
N I,J,TEMP,TEMPARR
K ^UTILITY($J,"W")
S DIWL=1
S DIWR=80
S DIWF="|"
I $G(ORTITLE)'="" D
. S ORINDENT=$L(ORTITLE)
. S DIWF=DIWF_"I"_ORINDENT
S X=$G(ORTEXT)
D ^DIWP
;
S ORX=0
F S ORX=$O(^UTILITY($J,"W",1,ORX)) Q:'ORX D
. S ORLINE=ORLINE+1
. S ORTEXT=$G(^UTILITY($J,"W",1,ORX,0))
. I $G(ORINDENT) D
. . S ORTEXT=ORTITLE_$E(ORTEXT,ORINDENT+1,999)
. . S ORINDENT=0
. S OROUTPUT(ORLINE)=ORTEXT
;
K ^UTILITY($J,"W")
Q
;
GETMAXDT() ; Get the Max date/time for the admin/read date/time fields
N OROVERDL,ORMAXDT
;
S OROVERDL=0
D OVERDL^ORWU(.OROVERDL) ; get value of ORPARAM OVER DATELINE
;
S ORMAXDT=$$NOW^XLFDT()
I OROVERDL S ORMAXDT=$$FMADD^XLFDT($$DT^XLFDT,1,23,59)
Q ORMAXDT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORFIMM1 12828 printed Oct 16, 2024@18:31:23 Page 2
ORFIMM1 ;SLC/AGP - GENERIC EDIT IMMUNIZATION CONT ;May 18, 2023@16:45:03
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**405,597,588**;Dec 17, 1997;Build 29
+2 ;
+3 ; Reference to IMMGRP^PXAPIIM in ICR #6387
+4 ; Reference to IMMROUTE^PXVRPC2 in ICR #7283
+5 ; Reference to GETUNITS^PXVRPC4 in ICR #7284
+6 ; Reference to ARTAPI^PXVUTIL in ICR #7398
+7 ;
+8 QUIT
+9 ;
BLD(RESULTS,LIST,INPUTS) ;
+1 NEW ADMINDATE,CAT,CNT,DATE,EXT,HASERR,ID,IDX,IMNAME,INT,MSG,NAME,NODE,NOTEARR,NOTEINP,PARM,PARR,PRMPTS,VIS,VISCNT
+2 NEW PIECE,X,DELSTR,DELSTR1,DELSTR2,DELSTR3
+3 NEW LOC,DATETIME,ENCTYPE,TYPE,VISITSTR,ORLOT
+4 ;
+5 SET ID=$GET(INPUTS("ID"))
SET IMNAME=$GET(INPUTS("NAME"))
+6 SET TYPE=$GET(INPUTS("DOCUMENTTYPE"))
+7 SET VISITSTR=$GET(INPUTS("VISITSTR"))
+8 SET LOC=$PIECE(VISITSTR,";")
SET DATETIME=$PIECE(VISITSTR,";",2)
SET ENCTYPE=$PIECE(VISITSTR,";",3)
+9 ;
+10 SET DELSTR=$SELECT(TYPE=2:"ICR+"_U_U_U_U,TYPE=3:"ICR+"_U_U_U_U,1:"IMM+"_U_ID_U_U_IMNAME)
+11 SET DELSTR1="COM"_U_1_U_"@"
SET $PIECE(DELSTR,U,$SELECT(TYPE=5:29,1:10))=1
+12 IF TYPE'=5
SET DELSTR2="COM"_U_2_U_"@"
SET $PIECE(DELSTR,U,24)=2
+13 SET HASERR=0
SET CNT=0
+14 ;
+15 DO BLDPRMPT^ORFEDT(.PRMPTS)
+16 DO BLDPARR^ORFEDT(.PARR)
+17 ;
+18 SET VISCNT=0
SET VIS=""
+19 SET IDX=0
FOR
SET IDX=$ORDER(LIST(IDX))
if IDX'>0!(HASERR=1)
QUIT
Begin DoDot:1
+20 SET NODE=LIST(IDX)
+21 SET NAME=$PIECE(NODE,U)
SET INT=$PIECE(NODE,U,2)
SET EXT=$PIECE(NODE,U,3)
+22 SET PARM=$GET(PARR(NAME))
+23 IF PARM?1(1"pnumComment",1"pnumImmOverride")
IF $LENGTH(NODE,"^")>3
Begin DoDot:2
+24 SET RESULTS(CNT)="-1^"_$SELECT(PARM="pnumImmOverride":"Override Reason",1:"Comment")_" cannot contain a caret symbol"
+25 SET HASERR=1
End DoDot:2
QUIT
+26 IF PARM="pnumIMMVIS"
Begin DoDot:2
+27 IF VIS=""
SET VIS=INT_"/"_$PIECE(ADMINDATE,".")
QUIT
+28 IF VIS'=""
SET VIS=VIS_";"_INT_"/"_$PIECE(ADMINDATE,".")
End DoDot:2
QUIT
+29 ;
+30 IF PARM="pnumAdminDate"
Begin DoDot:2
+31 SET PIECE=+$GET(PRMPTS(PARM))
+32 ; don't allow future admin/read times (unless over the dateline, allow up to T+1@23:59)
IF INT>$$GETMAXDT()
Begin DoDot:3
+33 SET RESULTS(CNT)="-1^"_$SELECT(TYPE=5:"Read",1:"Administration")_" Date"_$SELECT(TYPE=1:"",1:"/Time")_" cannot be a future date"_$SELECT(TYPE=1:"",1:"/Time")_"."
+34 SET HASERR=1
End DoDot:3
QUIT
+35 SET ADMINDATE=INT
+36 SET $PIECE(DELSTR,U,$SELECT(TYPE=5:27,1:PIECE))=INT
End DoDot:2
QUIT
+37 ;
+38 IF PARM="pnumImmLot"
Begin DoDot:2
+39 IF TYPE=1
SET INT=""
+40 IF TYPE=0
SET ORLOT=INT
End DoDot:2
+41 IF PARM=""
QUIT
+42 SET PIECE=+$GET(PRMPTS(PARM))
IF PIECE=0
QUIT
+43 DO BLDSTRS(.RESULTS,.CNT,PARM,TYPE,EXT,INT,PIECE,ID,IMNAME,LOC,.DELSTR,.DELSTR1,.DELSTR2,.MSG)
+44 IF $PIECE($GET(RESULTS(CNT)),U)=-1
SET HASERR=1
End DoDot:1
+45 ;
+46 IF TYPE=0
IF $GET(ORLOT)=""
IF 'HASERR
Begin DoDot:1
+47 SET RESULTS(CNT)="-1^Lot Number is required."
+48 SET HASERR=1
End DoDot:1
+49 ;
+50 IF HASERR=1
QUIT
+51 SET CNT=0
+52 SET $PIECE(DELSTR,U,PRMPTS("pnumIMMVIS"))=VIS
+53 IF TYPE=0
SET $PIECE(DELSTR,U,12)="00"
+54 SET RESULTS(CNT)=1_U_$SELECT(+$GET(ADMINDATE)>0:ADMINDATE,1:DATETIME)
+55 DO GETTEXT(.NOTEARR,.LIST,ID,IMNAME,TYPE,DATETIME,LOC,0)
+56 ;
+57 SET IDX=0
FOR
SET IDX=$ORDER(NOTEARR(IDX))
if IDX'>0
QUIT
SET CNT=CNT+1
SET RESULTS(CNT)="NOTE"_U_NOTEARR(IDX)
+58 SET CNT=CNT+1
SET RESULTS(CNT)="DATA"_U_DELSTR
+59 SET CNT=CNT+1
SET RESULTS(CNT)="DATA1"_U_$GET(DELSTR1)
+60 SET CNT=CNT+1
SET RESULTS(CNT)="DATA2"_U_$GET(DELSTR2)
+61 SET IDX=0
FOR
SET IDX=$ORDER(MSG(IDX))
if IDX'>0
QUIT
SET CNT=CNT+1
SET RESULTS(CNT)="MSG"_U_MSG(IDX)
+62 QUIT
+63 ;
BLDSTRS(RESULT,CNT,PARM,TYPE,EXT,INT,PIECE,ID,NAME,LOC,DELSTR,DELSTR1,DELSTR2,MSG) ;
+1 NEW IDX,TEMP
+2 IF PARM?1(1"pnumAdminByPolicy",1"pnumImmOrderByIEN",1"pnumImmSite",1"pnumImmSeries",1"pnumWarnDate")
Begin DoDot:1
+3 IF INT=""
SET INT="@"
End DoDot:1
+4 IF PARM="pnumDataSource"
SET $PIECE(DELSTR,U,PIECE)=EXT_";"_INT
QUIT
+5 IF PARM="pnumImmDosage"
DO DOSECHK(.RESULT,.CNT,.DELSTR,INT,ID,LOC,PIECE)
QUIT
+6 IF PARM="pnumImmRoute"
SET $PIECE(DELSTR,U,PIECE)=EXT_";;"_INT
QUIT
+7 IF PARM="pnumImmSite"
Begin DoDot:1
+8 DO CHK^DIE(9000010.11,1303,,$$TRIM^XLFSTR(EXT),.TEMP)
+9 IF TEMP="^"
IF (EXT'=""!(INT=-1))
IF INT'="@"
SET RESULT(CNT)="-1^Anatomic Location is not a valid selection"
QUIT
+10 SET $PIECE(DELSTR,U,PIECE)=EXT_";;"_INT
QUIT
End DoDot:1
QUIT
+11 IF PARM="pnumImmLot"
SET $PIECE(DELSTR,U,PIECE)=EXT_";"_INT
QUIT
+12 IF PARM="pnumImmManufacturer"
SET $PIECE(DELSTR,U,PIECE)=EXT
QUIT
+13 IF PARM="pnumExpirationDate"
SET $PIECE(DELSTR,U,PIECE)=$SELECT(EXT:$$FMTE^XLFDT(EXT,"2D"),1:EXT)
QUIT
+14 IF PARM="pnumImmOrderByIEN"
Begin DoDot:1
+15 SET $PIECE(DELSTR,U,PIECE)=INT
+16 IF INT=""!(INT="@")
SET $PIECE(DELSTR,U,31)=1
+17 IF INT>0
SET $PIECE(DELSTR,U,31)="@"
End DoDot:1
+18 IF PARM="pnumImmSeries"
Begin DoDot:1
+19 SET TEMP=$$EXTERNAL^DILFD(9000010.11,.04,,INT)
+20 IF TEMP=""
IF (EXT'=""!(INT=-1))
IF INT'="@"
SET RESULT(CNT)="-1^Series is not a valid selection"
QUIT
+21 SET $PIECE(DELSTR,U,PIECE)=INT
QUIT
End DoDot:1
QUIT
+22 IF PARM="pnumProvider"
SET $PIECE(DELSTR,U,$SELECT(TYPE=5:28,1:PIECE))=INT
QUIT
+23 IF PARM="pnumComment"
IF EXT'=""
Begin DoDot:1
+24 IF $LENGTH(EXT)>245
SET RESULT(CNT)="-1^Comment cannot exceed 245 characters"
QUIT
+25 SET DELSTR1="COM"_U_1_U_EXT
End DoDot:1
QUIT
+26 IF PARM="pnumImmOverride"
IF EXT'=""
Begin DoDot:1
+27 IF $LENGTH(EXT)>245
SET RESULT(CNT)="-1^Override Reason cannot exceed 245 characters"
QUIT
+28 SET $PIECE(DELSTR,U,23)=1
SET DELSTR2="COM"_U_2_U_EXT
End DoDot:1
QUIT
+29 IF PARM="pnumDataSource"
SET $PIECE(DELSTR,U,PIECE)=";"_INT
QUIT
+30 IF PARM="pnumImmContra"
Begin DoDot:1
+31 SET $PIECE(DELSTR,U,2)=INT_";PXV(920.4,"
SET $PIECE(DELSTR,U,4)=EXT
SET $PIECE(DELSTR,U,5)=ID_";"_NAME
+32 IF $$ARTAPI^PXVUTIL(INT)>0
Begin DoDot:2
+33 SET IDX=$ORDER(MSG(""),-1)
+34 IF IDX>0
SET IDX=IDX+1
SET MSG(IDX)=" "
+35 SET IDX=IDX+1
SET MSG(IDX)="You are recording an allergy/adverse reaction contraindication reason. This"
+36 SET IDX=IDX+1
SET MSG(IDX)="information should also be recorded in the Adverse Reaction Tracking package"
+37 SET IDX=IDX+1
SET MSG(IDX)="if it is not already present there."
End DoDot:2
End DoDot:1
QUIT
+38 IF PARM="pnumWarnDate"
Begin DoDot:1
+39 IF +INT>0
IF INT<$$NOW^XLFDT()
SET RESULT(CNT)="-1^Choose reschedule date cannot be in the past."
+40 SET $PIECE(DELSTR,U,PIECE)=INT
End DoDot:1
QUIT
+41 IF PARM="pnumImmRefused"
SET $PIECE(DELSTR,U,2)=INT_";PXV(920.5,"
SET $PIECE(DELSTR,U,4)=EXT
SET $PIECE(DELSTR,U,5)=ID_";"_NAME
QUIT
+42 IF PARM="pnumSkinResults"
SET $PIECE(DELSTR,U,25)=INT
QUIT
+43 IF PARM="pnumSkinReading"
SET $PIECE(DELSTR,U,26)=EXT
QUIT
+44 IF PARM="pnumReadingIEN"
SET $PIECE(DELSTR,U,30)=INT
QUIT
+45 IF PARM="pnumRefusedGroup"
SET $PIECE(DELSTR,U,9)=$SELECT(INT=1:0,1:1)
+46 QUIT
+47 ;
DOSECHK(RESULT,CNT,DELSTR,INT,ID,LOC,PIECE) ;
+1 NEW TEMP
+2 IF INT=""
QUIT
+3 SET INT=$$TRIM^XLFSTR(INT,"LR")
+4 ;check for any alpha characters
+5 IF INT?.E1A.E
SET RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits."
QUIT
+6 ;check for any punctuation characters beside a period
+7 SET TEMP=$TRANSLATE(INT,".","")
IF TEMP?.E1P.E
SET RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits."
QUIT
+8 ;check for control characters
+9 IF INT?.E1C.E
SET RESULT(CNT)="-1^Incorrect format for dose. Cannot contains a control character"
QUIT
+10 IF INT["."
Begin DoDot:1
+11 SET TEMP=$PIECE(INT,".",2)
IF $LENGTH(TEMP)>2
SET RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits."
QUIT
+12 SET TEMP=$PIECE(INT,".")
IF (TEMP>999)!(TEMP<0)
SET RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits."
QUIT
+13 SET TEMP=$$GETUNITS^PXVRPC4(ID,LOC)
+14 SET $PIECE(DELSTR,U,PIECE)=INT_";"_$PIECE(TEMP,U,2)
End DoDot:1
QUIT
+15 IF (INT>999)!(INT<0)
SET RESULT(CNT)="-1^Incorrect format for dose. Dose must be a number between 0 and 999, up to two fractional digits."
QUIT
+16 KILL TEMP
SET TEMP=$$GETUNITS^PXVRPC4(ID,LOC)
+17 SET $PIECE(DELSTR,U,PIECE)=INT_";"_$PIECE(TEMP,U,2)
+18 QUIT
+19 ;
+20 ;
GETROUTE(RESULT,CNT,DEFAULT,LOCLIST) ;
+1 NEW DEF,DATALST,ISLOC,X
+2 SET DEF=+$GET(DEFAULT("ADMIN ROUTE"))
+3 DO IMMROUTE^PXVRPC2(.DATALST,"S:A",1)
+4 SET ISLOC=0
+5 SET X=0
FOR
SET X=$ORDER(DATALST(X))
if X'>0
QUIT
Begin DoDot:1
+6 IF DATALST(X)'[U
QUIT
+7 IF DEF>0
IF +$PIECE(DATALST(X),U)>0
IF DEF=+$PIECE(DATALST(X),U)
SET ISLOC=1
+8 IF DEF>0
IF +$PIECE(DATALST(X),U)>0
IF DEF'=+$PIECE(DATALST(X),U)
SET ISLOC=0
+9 IF ISLOC
IF $PIECE(DATALST(X),U)="SITE"
SET LOCLIST($PIECE(DATALST(X),U,2))=""
+10 SET CNT=CNT+1
SET RESULT(CNT)="DATA"_U_"ADMIN ROUTE"_U_DATALST(X)
End DoDot:1
+11 QUIT
+12 ;
GETSTOP(RESULT,CNT,DEFAULTS,ID,DATETIME,ENCTYPE) ;
+1 SET CNT=CNT+1
SET RESULT(CNT)="DATA"_U_"STOP"_U_0_U_"No"
+2 SET CNT=CNT+1
SET RESULT(CNT)="DATA"_U_"STOP"_U_1_U_"Yes, this will stop the forecasting reminders of future doses"
+3 QUIT
+4 ;
GETTEXT(OUTPUT,LIST,ID,IMMNAME,TYPE,DATETIME,LOC,FORMAT) ;
+1 ;scheduling ICR 10040
+2 NEW I,J,DIV,NODE,ORGRPS,TEMP,TEMPARR,XLOC,VISCNT
+3 IF FORMAT=0
DO BLDDEFLS^ORFEDT(.LIST,.TEMPARR)
+4 IF FORMAT=1
MERGE TEMPARR=LIST
+5 SET I=0
+6 IF TYPE=2!(TYPE=3)
Begin DoDot:1
+7 DO FORMAT(.OUTPUT,.I,IMMNAME,"Immunization: ")
+8 IF TYPE=2
DO FORMAT(.OUTPUT,.I,$PIECE(TEMPARR("CONTRAINDICATED"),U,2),"Contraindication/Precaution Reason: ")
+9 IF TYPE=3
SET I=I+1
SET OUTPUT(I)="Refusal Reason: "_$PIECE(TEMPARR("REFUSAL"),U,2)
+10 IF $PIECE($GET(TEMPARR("STOP")),U)=1
SET I=I+1
SET OUTPUT(I)="Cancel Series and stop forecasting: Yes"
+11 IF $PIECE($GET(TEMPARR("WARN")),U,2)'=""
SET I=I+1
SET OUTPUT(I)="Warn Until: "_$TRANSLATE($$FMTE^XLFDT($PIECE(TEMPARR("WARN"),U,2),"2ZM"),"@"," ")
+12 IF TYPE=3
IF $PIECE($GET(TEMPARR("CVXONLY")),U)'=""
Begin DoDot:2
+13 IF +$PIECE($GET(TEMPARR("CVXONLY")),U)=0
Begin DoDot:3
+14 DO IMMGRP^PXAPIIM(.ORGRPS,ID)
+15 SET TEMP=$ORDER(ORGRPS("VG",""))
+16 DO FORMAT(.OUTPUT,.I,$SELECT(TEMP'="":"Patient refuses all immunization(s) in the "_TEMP_" group",1:"Patient refuses all immunization(s) in the group"))
End DoDot:3
QUIT
+17 DO FORMAT(.OUTPUT,.I,"Patient refuses the "_IMMNAME_" immunization")
End DoDot:2
+18 IF $PIECE($GET(TEMPARR("COMMENTS")),U,2)'=""
DO FORMAT(.OUTPUT,.I,$PIECE(TEMPARR("COMMENTS"),U,2),"Comment: ")
+19 SET I=I+1
SET OUTPUT(I)="Date Documented: "_$TRANSLATE($$FMTE^XLFDT($$NOW^XLFDT,"2ZM"),"@"," ")
End DoDot:1
QUIT
+20 ;
+21 SET TEMP=$SELECT(TYPE=0:"Administered",TYPE=1:"Documented",TYPE=2:"Contraindicated/Precaution",TYPE=3:"Refusal",TYPE=5:"Read",1:"")
+22 DO FORMAT(.OUTPUT,.I,IMMNAME,TEMP_": ")
+23 SET TEMP=$SELECT(TYPE=1:"Historical Date Administered",TYPE=5:"Date Read",1:"Date Administered")_": "
+24 IF TYPE=1
Begin DoDot:1
+25 SET TEMP=TEMP_$$FMTE^XLFDT($PIECE($GET(TEMPARR("VISIT DATE TIME")),U,2),1)
+26 IF $EXTRACT($PIECE($GET(TEMPARR("VISIT DATE TIME")),U,2),4,5)="00"
SET TEMP=TEMP_" Exact date unknown"
QUIT
+27 IF $EXTRACT($PIECE($GET(TEMPARR("VISIT DATE TIME")),U,2),6,7)="00"
SET TEMP=TEMP_" Exact date unknown"
QUIT
End DoDot:1
+28 IF TYPE'=1
SET TEMP=TEMP_$TRANSLATE($$FMTE^XLFDT($PIECE($GET(TEMPARR("VISIT DATE TIME")),U,2),1),"@"," ")
+29 ;determine label depending on admin vs historical
+30 SET I=I+1
SET OUTPUT(I)=$$LJ^XLFSTR(TEMP,50)
+31 IF $PIECE($GET(TEMPARR("SERIES")),U,2)'=""
SET OUTPUT(I)=OUTPUT(I)_$$LJ^XLFSTR("Series: "_$PIECE(TEMPARR("SERIES"),U,2),50)
+32 IF $PIECE($GET(TEMPARR("MANUFACTURER")),U,2)'=""
DO FORMAT(.OUTPUT,.I,$PIECE(TEMPARR("MANUFACTURER"),U,2),"Manufacturer: ")
+33 if $PIECE($GET(TEMPARR("LOT NUMBER")),U,2)'=""
SET I=I+1
SET OUTPUT(I)=$$LJ^XLFSTR("Lot: "_$PIECE(TEMPARR("LOT NUMBER"),U,2),50)_"Exp Date: "_$SELECT($PIECE($GET(TEMPARR("EXPIRATION DATE")),U,2)'="":$$FMTE^XLFDT($PIECE(TEMPARR("EXPIRATION DATE"),U,2),"1D"),1:"Unknown")
+34 if $PIECE($GET(TEMPARR("LOT NUMBER")),U,7)'=""
SET I=I+1
SET OUTPUT(I)=$$LJ^XLFSTR("NDC: "_$PIECE(TEMPARR("LOT NUMBER"),U,7),50)
+35 ;
+36 ;determine label depending on admin vs historical
+37 IF +LOC=LOC
SET LOC=$$GET1^DIQ(44,LOC,.01)
+38 SET XLOC=""
+39 IF TYPE=1
SET TEMP="Outside Location: "
SET XLOC=$PIECE(TEMPARR("LOCATION"),U,2)
+40 ;I TYPE=0 S TEMP="Location: ",XLOC=LOC
+41 SET TEMP=TEMP_XLOC
+42 IF XLOC'=""
SET I=I+1
SET OUTPUT(I)=$$LJ^XLFSTR(TEMP,60)
+43 ;
+44 if $PIECE($GET(TEMPARR("ADMIN ROUTE")),U,2)'=""
SET I=I+1
SET OUTPUT(I)="Admin Route/Site: "_$PIECE(TEMPARR("ADMIN ROUTE"),U,2)_"/"_$PIECE($GET(TEMPARR("ADMIN SITE")),U,2)
+45 IF $PIECE($GET(TEMPARR("DOSE")),U,2)'=""
Begin DoDot:1
+46 SET DIV=$SELECT(+$PIECE($GET(^SC(+LOC,0)),U,15)>0:+$PIECE($GET(^SC(+LOC,0)),U,15),1:DUZ(2))
+47 SET TEMP=$$GETUNITS^PXVRPC4(ID,DIV)
+48 SET I=I+1
SET OUTPUT(I)="Dosage: "_$PIECE(TEMPARR("DOSE"),U,2)_$SELECT($PIECE(TEMP,U,2)'="":$PIECE(TEMP,U,2),$PIECE(TEMP,U,3)'="":$PIECE(TEMP,U,3),1:"")
End DoDot:1
+49 if $PIECE($GET(TEMPARR("INFO SOURCE")),U,2)'=""
SET I=I+1
SET OUTPUT(I)="Information Source: "_$PIECE(TEMPARR("INFO SOURCE"),U,2)
+50 ;
+51 IF $DATA(TEMPARR("VIS OFFERED"))
Begin DoDot:1
+52 SET I=I+1
SET OUTPUT(I)="Vaccine Information Statement(s):"
+53 IF $DATA(TEMPARR("VIS OFFERED"))=1
DO FORMAT(.OUTPUT,.I,$PIECE($PIECE(TEMPARR("VIS OFFERED"),U,2),";")," ")
QUIT
+54 SET VISCNT=0
FOR
SET VISCNT=$ORDER(TEMPARR("VIS OFFERED",VISCNT))
if VISCNT'>0
QUIT
Begin DoDot:2
+55 DO FORMAT(.OUTPUT,.I,$PIECE($PIECE(TEMPARR("VIS OFFERED",VISCNT),U,2),";")," ")
End DoDot:2
End DoDot:1
+56 IF TYPE=0
SET I=I+1
SET OUTPUT(I)="Order By: "_$SELECT($PIECE($GET(TEMPARR("ORDERING PROVIDER")),U,2)'="":$PIECE(TEMPARR("ORDERING PROVIDER"),U,2),1:"Policy")
+57 IF $PIECE($GET(TEMPARR("ENCOUNTER PROVIDER")),U,2)'=""
Begin DoDot:1
+58 SET I=I+1
SET OUTPUT(I)=$SELECT(TYPE=5:"Read By:",TYPE=0:"Administered By: ",1:"Documented By: ")_$PIECE(TEMPARR("ENCOUNTER PROVIDER"),U,2)
End DoDot:1
+59 IF $PIECE($GET(TEMPARR("COMMENTS")),U,2)'=""
DO FORMAT(.OUTPUT,.I,$PIECE(TEMPARR("COMMENTS"),U,2),"Comment: ")
+60 IF $PIECE($GET(TEMPARR("OVERRIDE REASON")),U,2)'=""
DO FORMAT(.OUTPUT,.I,$PIECE(TEMPARR("OVERRIDE REASON"),U,2),"Override Reason: ")
+61 IF $PIECE($GET(TEMPARR("PLACEMENT IEN")),U,2)'=""
SET I=I+1
SET OUTPUT(I)="Measurements: "_$PIECE($GET(TEMPARR("READING")),U,2)
+62 IF $PIECE($GET(TEMPARR("RESULTS")),U,2)'=""
SET I=I+1
SET OUTPUT(I)="Interpretation: "_$PIECE($GET(TEMPARR("RESULTS")),U,2)
+63 SET I=I+1
SET OUTPUT(I)=" "
+64 QUIT
+65 ;
FORMAT(OROUTPUT,ORLINE,ORTEXT,ORTITLE) ;
+1 NEW DIWL,DIWR,DIWF,X,ORX,ORINDENT
+2 NEW I,J,TEMP,TEMPARR
+3 KILL ^UTILITY($JOB,"W")
+4 SET DIWL=1
+5 SET DIWR=80
+6 SET DIWF="|"
+7 IF $GET(ORTITLE)'=""
Begin DoDot:1
+8 SET ORINDENT=$LENGTH(ORTITLE)
+9 SET DIWF=DIWF_"I"_ORINDENT
End DoDot:1
+10 SET X=$GET(ORTEXT)
+11 DO ^DIWP
+12 ;
+13 SET ORX=0
+14 FOR
SET ORX=$ORDER(^UTILITY($JOB,"W",1,ORX))
if 'ORX
QUIT
Begin DoDot:1
+15 SET ORLINE=ORLINE+1
+16 SET ORTEXT=$GET(^UTILITY($JOB,"W",1,ORX,0))
+17 IF $GET(ORINDENT)
Begin DoDot:2
+18 SET ORTEXT=ORTITLE_$EXTRACT(ORTEXT,ORINDENT+1,999)
+19 SET ORINDENT=0
End DoDot:2
+20 SET OROUTPUT(ORLINE)=ORTEXT
End DoDot:1
+21 ;
+22 KILL ^UTILITY($JOB,"W")
+23 QUIT
+24 ;
GETMAXDT() ; Get the Max date/time for the admin/read date/time fields
+1 NEW OROVERDL,ORMAXDT
+2 ;
+3 SET OROVERDL=0
+4 ; get value of ORPARAM OVER DATELINE
DO OVERDL^ORWU(.OROVERDL)
+5 ;
+6 SET ORMAXDT=$$NOW^XLFDT()
+7 IF OROVERDL
SET ORMAXDT=$$FMADD^XLFDT($$DT^XLFDT,1,23,59)
+8 QUIT ORMAXDT
