PXRMIMM ;SLC/PKR - Handle immunization findings. ;03/31/2022
;;2.0;CLINICAL REMINDERS;**42,65**;Feb 04, 2005;Build 438
;
; API ICR#
;PATICR^PXAPIIM 6387
;^AUPNVSIT 2028
;VIMM^PXPXRM 6992
;IMMGRP^PXAPIIM 6387
;BROWSE^DDBR 5746
;
;====================
CRFINDING(DFN,ITEM,FINDING,CRFIEVAL) ;Determine if there are any active contraindication, precautions,
;or refusals.
N CRLIST,CRTYPE,DATE,DATEORDER,NCR,NCRF,SUB
D CRLIST(DFN,ITEM,0,.NCRF,.CRLIST)
F CRTYPE="CONTRA","PRECAUTION","REFUSED" D
.;Only keep active C/R.
. I CRLIST(CRTYPE)=0 Q
. S CRFIEVAL(CRTYPE,FINDING)=CRLIST(CRTYPE)
. F NCR=1:1:NCRF(CRTYPE) D
.. K DATEORDER
.. S SUB=""
.. F S SUB=$O(CRLIST(CRTYPE,NCR,SUB)) Q:SUB="" D
... S CRFIEVAL(CRTYPE,FINDING,NCR,SUB)=CRLIST(CRTYPE,NCR,SUB)
... I SUB="DATE" S DATE=CRLIST(CRTYPE,NCR,SUB),DATEORDER(DATE,NCR)=""
..;Save the most recent as the overall result.
.. S DATE=$O(DATEORDER(""),-1)
.. S NCR=$O(DATEORDER(DATE,""))
.. S SUB=""
.. F S SUB=$O(CRFIEVAL(CRTYPE,FINDING,NCR,SUB)) Q:SUB="" D
... S CRFIEVAL(CRTYPE,FINDING,SUB)=CRFIEVAL(CRTYPE,FINDING,NCR,SUB)
Q
;
;====================
CRLIST(DFN,IMMIEN,BDT,NCRF,CRLIST) ;Check for contraindications and refusals.
N CRDATA,CRTYPE,CRVP,DAS,EVENTDT,NUM,TEMP,VISITIEN,WUDT,WUDTL
K CRLIST
S (CRLIST("CONTRA"),CRLIST("PRECAUTION"),CRLIST("REFUSED"))=0
;Call PATICR^PXAPIIM to get a list of all of the patient's
;contraindications, precautions, and refusals.
D PATICR^PXAPIIM(.CRDATA,DFN,IMMIEN,BDT,"")
S DAS="",WUDT=PXRMDATE
F S DAS=$O(CRDATA(DAS)) Q:(WUDT="")!(DAS="") D
. S WUDT=+$P(CRDATA(DAS),U,4)
.;If Warn Until Date is null the contra/refusal is permanent.
. I (WUDT>0),(PXRMDATE>WUDT) Q
. S TEMP=$P(CRDATA(DAS),U,2)
. S CRVP=$P(TEMP,"|",1)
. S CRTYPE=$S(CRVP["920.4":"CONTRA",CRVP["920.5":"REFUSED",1:"")
. I CRTYPE="" Q
. I CRTYPE="CONTRA" S CRTYPE=$S(CRDATA(DAS,"CONTRAINDICATION/PRECAUTION")="C":"CONTRA",CRDATA(DAS,"CONTRAINDICATION/PRECAUTION")="P":"PRECAUTION")
. S WUDTL(CRTYPE,WUDT,DAS)=""
I '$D(WUDTL) Q
;Sort the list by Warn Until Date.
F CRTYPE="CONTRA","PRECAUTION","REFUSED" D
. S NUM=0,WUDT=""
. F S WUDT=$O(WUDTL(CRTYPE,WUDT)) Q:WUDT="" D
.. S CRLIST(CRTYPE)=1
.. S DAS=""
.. F S DAS=$O(WUDTL(CRTYPE,WUDT,DAS)) Q:DAS="" D
... S NUM=NUM+1
... S TEMP=$P(CRDATA(DAS),U,2)
... S EVENTDT=$P(CRDATA(DAS),U,6)
... I EVENTDT="" D
.... S VISITIEN=$P(CRDATA(DAS),U,1)
.... S EVENTDT=$P(^AUPNVSIT(VISITIEN,0),U,1)
... S CRLIST(CRTYPE,NUM,"COMMENTS")=$G(CRDATA(DAS,"COMMENTS"))
... S CRLIST(CRTYPE,NUM,"DATE")=EVENTDT
... S CRLIST(CRTYPE,NUM,"REASON")=$P(TEMP,"|",2)
... I $P(CRDATA(DAS),U,8)=1 S CRLIST(CRTYPE,NUM,"GROUP REFUSAL")="Patient has refused all vaccines in the group."
... S CRLIST(CRTYPE,NUM,"WUDT")=WUDT
. S NCRF(CRTYPE)=NUM
Q
;
;====================
CVXL(ITEM,NOCC,BDT,EDT,PLIST) ;Find patient list immunizations by CVX code.
N CVX,DAS,DATE,DFN,DS,NFOUND
K ^TMP($J,PLIST)
S CVX=$P(^AUTTIMM(ITEM,0),U,3)
I CVX="" Q
S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
S DFN=0
F S DFN=$O(^PXRMINDX(9000010.11,"CVX","IP",CVX,DFN)) Q:DFN="" D
. S NFOUND=0
. S DATE=DS
. F S DATE=+$O(^PXRMINDX(9000010.11,"CVX","IP",CVX,DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT)!(NFOUND=NOCC) D
.. S DAS=""
.. F S DAS=$O(^PXRMINDX(9000010.11,"CVX","IP",CVX,DFN,DATE,DAS),-1) Q:DAS="" D
... S NFOUND=NFOUND+1
... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_DATE
Q
;
;====================
CVXP(DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient immunizations
;by CVX code.
N CVX,DAS,DATE,DONE,EDTT
S (DONE,NFOUND)=0
S CVX=$P(^AUTTIMM(ITEM,0),U,3)
I CVX="" Q
S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
S DATE=$S(SDIR=+1:BDT-.000001,1:EDTT)
F S DATE=+$O(^PXRMINDX(9000010.11,"CVX","PI",DFN,CVX,DATE),SDIR) Q:(DATE=0)!(DONE) D
. I DATE<BDT,SDIR=-1 S DONE=1 Q
. I DATE>EDTT,SDIR=1 S DONE=1 Q
. S DAS=""
. F S DAS=$O(^PXRMINDX(9000010.11,"CVX","PI",DFN,CVX,DATE,DAS),-1) Q:DAS="" D
.. S NFOUND=NFOUND+1
.. S FLIST(NFOUND)=DAS_U_DATE
.. I NFOUND=NGET S DONE=1 Q
Q
;
;====================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate immunization findings.
D EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL)
Q
;
;====================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate immunization term findings
;for patient lists.
D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
Q
;
;====================
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate immunization terms.
D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
;Determine the term's contra/refused status. If all the mapped findings are contra, the status
;is CONTRA. If all the mapped findings are REFUSED, the status is REFUSED. If a mapped
;finding is both CONTRA and REFUSED count it as CONTRA. If all the mapped
;findings are either CONTRA or REFUSED the status is REFUSED.
N FINDING,NCONTRA,NF,NPREC,NREFUSED
S (FINDING,NCONTRA,NF,NPREC,NREFUSED)=0
F S FINDING=$O(TERMARR(20,FINDING)) Q:FINDING="" D
. S NF=NF+1
. I $G(TFIEVAL("CONTRA",FINDING))=1 S NCONTRA=NCONTRA+1
. I $G(TFIEVAL("PRECAUTION",FINDING))=1 S NPREC=NPREC+1
. I ($G(TFIEVAL("CONTRA",FINDING))'=1),($G(TFIEVAL("REFUSED",FINDING))=1) S NREFUSED=NREFUSED+1
I NCONTRA=NF S TFIEVAL("C/R STATUS")="CONTRA"
I NREFUSED=NF S TFIEVAL("C/R STATUS")="REFUSED"
I (NREFUSED>0),(NCONTRA+NREFUSED)=NF S TFIEVAL("C/R STATUS")="REFUSED"
I '$D(TFIEVAL("C/R STATUS")),(NPREC>0) S TFIEVAL("C/R STATUS")="PRECAUTION"
Q
;
;====================
GETDATA(DAS,FIEVT) ;Return data, for a specified V Immunization entry.
D VIMM^PXPXRM(DAS,.FIEVT,1)
Q
;
;====================
ISCXHELP(DA,FILENUM) ;Executable help for the Immunization Search Criteria
;finding modifier.
N CVX,DDS,IEN,IMM,IMMIEN,IMMGRP,NLINES,TEXT,VGN,X
S IMM=$S(FILENUM=811.5:$P(^PXRMD(811.5,DA(1),20,DA,0),U,1),FILENUM=811.9:$P(^PXD(811.9,DA(1),20,DA,0),U,1),1:"")
I IMM'["AUTTIM" Q
S IMMIEN=$P(IMM,";",1)
D IMMGRP^PXAPIIM(.IMMGRP,IMMIEN)
S NLINES=0
S CVX=$O(IMMGRP("CVX",""))
S NLINES=NLINES+1,TEXT(NLINES)="Immunizations with the CVX code "_CVX_", are:"
S IEN=""
F S IEN=$O(IMMGRP("CVX",CVX,IEN)) Q:IEN="" D
. S NLINES=NLINES+1,TEXT(NLINES)=IMMGRP("CVX",CVX,IEN)_" (IEN="_IEN_")"
S VGN=$O(IMMGRP("VG",""))
S NLINES=NLINES+1,TEXT(NLINES)=""
I VGN="" S NLINES=NLINES+1,TEXT(NLINES)="This immunization is not in a vaccine group."
E D
. S NLINES=NLINES+1,TEXT(NLINES)="Immunizations in the vaccine group "_VGN_", are:"
. S IEN=""
. F S IEN=$O(IMMGRP("VG",VGN,IEN)) Q:IEN="" D
.. S NLINES=NLINES+1,TEXT(NLINES)=IMMGRP("VG",VGN,IEN)_" (IEN="_IEN_")"
S NLINES=NLINES+1,TEXT(NLINES)=""
;DBIA #5746 covers kill and set of DDS. DDS needs to be set or the
;Browser will kill some ScreenMan variables.
S DDS=1
S X="IORESET"
D ENDR^%ZISS
D BROWSE^DDBR("TEXT","NR","Immunization Search Criteria Help")
W IORESET
D KILL^%ZISS
Q
;
;====================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
;maintenance output.
N EM,FIEN,IND,JND,NAME,NOUT,PNAME,REACTION,SERIES,TEMP,TEXTOUT,VDATE
S FIEN=$P(IFIEVAL("FINDING"),";",1)
S PNAME=$P(^AUTTIMM(FIEN,0),U,1)
S NAME="Immunization: "_PNAME_" = "
S IND=0
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
. S SERIES=$G(IFIEVAL(IND,"SERIES"))
. I SERIES'="" S SERIES=$$EXTERNAL^DILFD(9000010.11,.04,"",SERIES,.EM)
. S VDATE=IFIEVAL(IND,"DATE")
. S TEMP=NAME_SERIES_" ("_$$EDATE^PXRMDATE(VDATE)_")"
. D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
S NLINES=NLINES+1,TEXT(NLINES)=""
Q
;
;====================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
;maintenance output.
N CONREF,CVX,EM,FIEN,IND,INDENTP1,ISC,JND,NOUT,PNAME
N REACTION,SERIES,TEMP,TEXTOUT,VDATE,WUDT
S FIEN=$P(IFIEVAL("FINDING"),";",1)
S PNAME=$P(^AUTTIMM(FIEN,0),U,1)
S INDENTP1=INDENT+1
I INDENT+14+$L(PNAME)<81 D
. S NLINES=NLINES+1
. S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Immunization: "_PNAME
E D
. N COL1W,COL2W,FMTSTR
. S TEMP="Immunization:^"_PNAME
. S COL1W=INDENT+13,COL2W=80-COL1W
. S FMTSTR=COL1W_"R1^"_COL2W_"L"
. D COLFMT^PXRMTEXT(FMTSTR,TEMP," ",.NOUT,.TEXTOUT)
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
S ISC=$G(IFIEVAL("ISC"))
I ISC="CVX" D
. S NLINES=NLINES+1,TEXT(NLINES)=" CVX search enabled for CVX "_IFIEVAL("CVX")_"."
I ISC="VGN" D
. S TEMP=" Vaccine Group search enabled for vaccine groups:"
. S (JND,IND)=0
. F S IND=+$O(^AUTTIMM(FIEN,7,IND)) Q:IND=0 D
.. S JND=JND+1
.. I JND>1 S TEMP=TEMP_","
.. S TEMP=TEMP_" "_^AUTTIMM(FIEN,7,IND,0)
. S TEMP=TEMP_"."
. D FORMATS^PXRMTEXT(INDENTP1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
S IND=0
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
. S VDATE=IFIEVAL(IND,"DATE")
. S TEMP=$$EDATE^PXRMDATE(VDATE)
. I ISC'="" S TEMP=TEMP_" "_IFIEVAL(IND,"IMMUNIZATION")
. S REACTION=$G(IFIEVAL(IND,"REACTION"))
. S SERIES=$G(IFIEVAL(IND,"SERIES"))
. I SERIES'="" D
.. S TEMP=TEMP_" series - "
.. S TEMP=TEMP_$$EXTERNAL^DILFD(9000010.11,.04,"",SERIES,.EM)
. I REACTION'="" D
.. S TEMP=TEMP_" reaction - "
.. S TEMP=TEMP_$$EXTERNAL^DILFD(9000010.11,.06,"",REACTION,.EM)
. D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
. I $G(IFIEVAL(IND,"COMMENTS"))'="" D
.. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
.. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
.. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
S NLINES=NLINES+1,TEXT(NLINES)=""
Q
;
;====================
OUTPUTCONREF(INDENT,CRTYPE,DEFARR,FIEVAL,NTXT) ;Output contraindication, precaution, and refusal information.
N DATE,IEN,JND,FINDING,FINUM,GBL,INDENTP1,NOCC,NLINES,NOUT,PNAME,TEMP,TEXT,TEXTOUT,WUDT
S PNAME=$S(CRTYPE="CONTRA":"Contraindications",CRTYPE="PRECAUTION":"Precautions",CRTYPE="REFUSED":"Refusals",1:"")
I PNAME="" Q
S TEXT(1)="",TEXT(2)=PNAME
D ADDTXTA^PXRMOUTU(INDENT,PXRMRM,.NTXT,2,.TEXT)
S INDENTP1=INDENT+1
S NLINES=0
S FINUM=""
F S FINUM=$O(FIEVAL(CRTYPE,FINUM)) Q:FINUM="" D
. S FINDING=$P(DEFARR(20,FINUM,0),U,1)
. S IEN=$P(FINDING,";",1)
. S GBL=$P(FINDING,";",2)
.;If it is not an immunization or term then it is unexpected.
. S PNAME="Unexpected finding :"_FINDING
. I GBL="AUTTIMM(" S PNAME="Immunization: "_$P(^AUTTIMM(IEN,0),U,1)
. I GBL="PXRMD(811.5," S PNAME="Reminder Term: "_$P(^PXRMD(811.5,IEN,0),U,1)
. S NLINES=NLINES+1,TEXT(NLINES)=$$REPEAT^XLFSTR(" ",INDENTP1)_PNAME
. S NOCC=0
. F S NOCC=+$O(FIEVAL(CRTYPE,FINUM,NOCC)) Q:NOCC=0 D
.. S DATE=FIEVAL(CRTYPE,FINUM,NOCC,"DATE")
.. S TEMP=$$EDATE^PXRMDATE(DATE)
.. S TEMP=TEMP_" Reason: "_$G(FIEVAL(CRTYPE,FINUM,NOCC,"REASON"))
.. S WUDT=FIEVAL(CRTYPE,FINUM,NOCC,"WUDT")
.. S TEMP=TEMP_$S(WUDT=0:", is permanent.",1:", expires "_$$EDATE^PXRMDATE(WUDT)_".")
.. D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
.. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
.. I $G(FIEVAL(CRTYPE,FINUM,NOCC,"COMMENTS"))'="" D
... S TEMP="Comments: "_FIEVAL(CRTYPE,FINUM,"COMMENTS")
... D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
... F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
.. I $G(FIEVAL(CRTYPE,FINUM,NOCC,"GROUP REFUSAL"))'="" D
... S NLINES=NLINES+1,TEXT(NLINES)=$$REPEAT^XLFSTR(" ",INDENTP1)_FIEVAL(CRTYPE,FINUM,NOCC,"GROUP REFUSAL")
I NLINES>0 D COPYTXT^PXRMOUTU(.NTXT,NLINES,.TEXT)
Q
;
;====================
TERMCRFINDING(TFIEVAL,FINDING,FIEVAL) ;Save the contraindication, precaution, refusal values of a
;term. Called from EVALFI^PXRMTERM.
N CRTYPE,DATE,DATEORDER,SUB1,SUB2,TFINDING,TYPELIST
;If a contraindication or refusal was found it is in TFIEVAL("C/R STATUS"),
;save it to the TYPELIST.
S TYPELIST(TFIEVAL("C/R STATUS"))=""
;Add precautions to the TYPELIST so if there are any they will be saved
;in FIEVAL("PRECAUTION,FINDING). This allows precautions to be displayed
;in the reminder evaluation output.
S TYPELIST("PRECAUTION")=""
S CRTYPE=""
F S CRTYPE=$O(TYPELIST(CRTYPE)) Q:CRTYPE="" D
. I '$D(TFIEVAL(CRTYPE)) Q
. K DATEORDER
. S TFINDING=""
. F S TFINDING=$O(TFIEVAL(CRTYPE,TFINDING)) Q:TFINDING="" D
.. S DATE=TFIEVAL(CRTYPE,TFINDING,"DATE")
.. S DATEORDER(DATE,TFINDING)=""
.;Save the term finding with the most recent date as
.;value of the finding.
. S DATE=$O(DATEORDER(""),-1)
. S TFINDING=$O(DATEORDER(DATE,""))
. S FIEVAL(CRTYPE,FINDING)=TFIEVAL(CRTYPE,TFINDING)
.;Save the rest of the term into the finding.
. S DATE=""
. F S DATE=$O(DATEORDER(DATE),-1) Q:DATE="" D
.. S TFINDING=""
.. F S TFINDING=$O(DATEORDER(DATE,TFINDING)) Q:TFINDING="" D
... S SUB1=""
... F S SUB1=$O(TFIEVAL(CRTYPE,TFINDING,SUB1)) Q:SUB1="" D
.... I +SUB1=0 S FIEVAL(CRTYPE,FINDING,SUB1)=TFIEVAL(CRTYPE,TFINDING,SUB1) Q
.... S SUB2=""
.... F S SUB2=$O(TFIEVAL(CRTYPE,TFINDING,SUB1,SUB2)) Q:SUB2="" D
..... S FIEVAL(CRTYPE,FINDING,SUB1,SUB2)=TFIEVAL(CRTYPE,TFINDING,SUB1,SUB2)
Q
;
;====================
VGNL(ITEM,NOCC,BDT,EDT,PLIST) ;Find patient list immunizations by Vaccine
;Group Names.
N DAS,DATE,DFN,DS,IMM,IND,NFOUND,VGN,VGNL
K ^TMP($J,PLIST)
I '$D(^AUTTIMM(ITEM,7)) Q
S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
;Build the list of immunizations based on the vaccine groups.
S IND=0
F S IND=+$O(^AUTTIMM(ITEM,7,IND)) Q:IND=0 D
. S VGN=^AUTTIMM(ITEM,7,IND,0)
. M VGNL=^AUTTIMM("I",VGN)
S IMM=""
F S IMM=$O(VGNL(IMM)) Q:IMM="" D
. S DFN=0
. F S DFN=$O(^PXRMINDX(9000010.11,"IP",IMM,DFN)) Q:DFN="" D
.. S NFOUND=0
.. S DATE=DS
.. F S DATE=+$O(^PXRMINDX(9000010.11,"IP",IMM,DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT)!(NFOUND=NOCC) D
... S DAS=""
... F S DAS=$O(^PXRMINDX(9000010.11,"IP",IMM,DFN,DATE,DAS),-1) Q:DAS="" D
.... S NFOUND=NFOUND+1
.... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_DATE
Q
;
;====================
VGNP(DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient immunizations
;by Vaccine Group Names.
N DAS,DATE,DONE,DS,EDTT,IMM,IND,VGN,VGNL
S (DONE,NFOUND)=0
I '$D(^AUTTIMM(ITEM,7)) Q
S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
S DS=$S(SDIR=+1:BDT-.000001,1:EDTT)
;Build the list of immunizations based on the vaccine groups.
S IND=0
F S IND=+$O(^AUTTIMM(ITEM,7,IND)) Q:IND=0 D
. S VGN=^AUTTIMM(ITEM,7,IND,0)
. M VGNL=^AUTTIMM("I",VGN)
S IMM=""
F S IMM=$O(VGNL(IMM)) Q:IMM="" D
. S DATE=DS
. F S DATE=+$O(^PXRMINDX(9000010.11,"PI",DFN,IMM,DATE),SDIR) Q:(DATE=0)!(DONE) D
.. I DATE<BDT,SDIR=-1 S DONE=1 Q
.. I DATE>EDTT,SDIR=1 S DONE=1 Q
.. S DAS=""
.. F S DAS=$O(^PXRMINDX(9000010.11,"PI",DFN,IMM,DATE,DAS),-1) Q:DAS="" D
... S NFOUND=NFOUND+1
... S FLIST(NFOUND)=DAS_U_DATE
... I NFOUND=NGET S DONE=1 Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMIMM 15069 printed Oct 16, 2024@17:46:59 Page 2
PXRMIMM ;SLC/PKR - Handle immunization findings. ;03/31/2022
+1 ;;2.0;CLINICAL REMINDERS;**42,65**;Feb 04, 2005;Build 438
+2 ;
+3 ; API ICR#
+4 ;PATICR^PXAPIIM 6387
+5 ;^AUPNVSIT 2028
+6 ;VIMM^PXPXRM 6992
+7 ;IMMGRP^PXAPIIM 6387
+8 ;BROWSE^DDBR 5746
+9 ;
+10 ;====================
CRFINDING(DFN,ITEM,FINDING,CRFIEVAL) ;Determine if there are any active contraindication, precautions,
+1 ;or refusals.
+2 NEW CRLIST,CRTYPE,DATE,DATEORDER,NCR,NCRF,SUB
+3 DO CRLIST(DFN,ITEM,0,.NCRF,.CRLIST)
+4 FOR CRTYPE="CONTRA","PRECAUTION","REFUSED"
Begin DoDot:1
+5 ;Only keep active C/R.
+6 IF CRLIST(CRTYPE)=0
QUIT
+7 SET CRFIEVAL(CRTYPE,FINDING)=CRLIST(CRTYPE)
+8 FOR NCR=1:1:NCRF(CRTYPE)
Begin DoDot:2
+9 KILL DATEORDER
+10 SET SUB=""
+11 FOR
SET SUB=$ORDER(CRLIST(CRTYPE,NCR,SUB))
if SUB=""
QUIT
Begin DoDot:3
+12 SET CRFIEVAL(CRTYPE,FINDING,NCR,SUB)=CRLIST(CRTYPE,NCR,SUB)
+13 IF SUB="DATE"
SET DATE=CRLIST(CRTYPE,NCR,SUB)
SET DATEORDER(DATE,NCR)=""
End DoDot:3
+14 ;Save the most recent as the overall result.
+15 SET DATE=$ORDER(DATEORDER(""),-1)
+16 SET NCR=$ORDER(DATEORDER(DATE,""))
+17 SET SUB=""
+18 FOR
SET SUB=$ORDER(CRFIEVAL(CRTYPE,FINDING,NCR,SUB))
if SUB=""
QUIT
Begin DoDot:3
+19 SET CRFIEVAL(CRTYPE,FINDING,SUB)=CRFIEVAL(CRTYPE,FINDING,NCR,SUB)
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
+22 ;====================
CRLIST(DFN,IMMIEN,BDT,NCRF,CRLIST) ;Check for contraindications and refusals.
+1 NEW CRDATA,CRTYPE,CRVP,DAS,EVENTDT,NUM,TEMP,VISITIEN,WUDT,WUDTL
+2 KILL CRLIST
+3 SET (CRLIST("CONTRA"),CRLIST("PRECAUTION"),CRLIST("REFUSED"))=0
+4 ;Call PATICR^PXAPIIM to get a list of all of the patient's
+5 ;contraindications, precautions, and refusals.
+6 DO PATICR^PXAPIIM(.CRDATA,DFN,IMMIEN,BDT,"")
+7 SET DAS=""
SET WUDT=PXRMDATE
+8 FOR
SET DAS=$ORDER(CRDATA(DAS))
if (WUDT="")!(DAS="")
QUIT
Begin DoDot:1
+9 SET WUDT=+$PIECE(CRDATA(DAS),U,4)
+10 ;If Warn Until Date is null the contra/refusal is permanent.
+11 IF (WUDT>0)
IF (PXRMDATE>WUDT)
QUIT
+12 SET TEMP=$PIECE(CRDATA(DAS),U,2)
+13 SET CRVP=$PIECE(TEMP,"|",1)
+14 SET CRTYPE=$SELECT(CRVP["920.4":"CONTRA",CRVP["920.5":"REFUSED",1:"")
+15 IF CRTYPE=""
QUIT
+16 IF CRTYPE="CONTRA"
SET CRTYPE=$SELECT(CRDATA(DAS,"CONTRAINDICATION/PRECAUTION")="C":"CONTRA",CRDATA(DAS,"CONTRAINDICATION/PRECAUTION")="P":"PRECAUTION")
+17 SET WUDTL(CRTYPE,WUDT,DAS)=""
End DoDot:1
+18 IF '$DATA(WUDTL)
QUIT
+19 ;Sort the list by Warn Until Date.
+20 FOR CRTYPE="CONTRA","PRECAUTION","REFUSED"
Begin DoDot:1
+21 SET NUM=0
SET WUDT=""
+22 FOR
SET WUDT=$ORDER(WUDTL(CRTYPE,WUDT))
if WUDT=""
QUIT
Begin DoDot:2
+23 SET CRLIST(CRTYPE)=1
+24 SET DAS=""
+25 FOR
SET DAS=$ORDER(WUDTL(CRTYPE,WUDT,DAS))
if DAS=""
QUIT
Begin DoDot:3
+26 SET NUM=NUM+1
+27 SET TEMP=$PIECE(CRDATA(DAS),U,2)
+28 SET EVENTDT=$PIECE(CRDATA(DAS),U,6)
+29 IF EVENTDT=""
Begin DoDot:4
+30 SET VISITIEN=$PIECE(CRDATA(DAS),U,1)
+31 SET EVENTDT=$PIECE(^AUPNVSIT(VISITIEN,0),U,1)
End DoDot:4
+32 SET CRLIST(CRTYPE,NUM,"COMMENTS")=$GET(CRDATA(DAS,"COMMENTS"))
+33 SET CRLIST(CRTYPE,NUM,"DATE")=EVENTDT
+34 SET CRLIST(CRTYPE,NUM,"REASON")=$PIECE(TEMP,"|",2)
+35 IF $PIECE(CRDATA(DAS),U,8)=1
SET CRLIST(CRTYPE,NUM,"GROUP REFUSAL")="Patient has refused all vaccines in the group."
+36 SET CRLIST(CRTYPE,NUM,"WUDT")=WUDT
End DoDot:3
End DoDot:2
+37 SET NCRF(CRTYPE)=NUM
End DoDot:1
+38 QUIT
+39 ;
+40 ;====================
CVXL(ITEM,NOCC,BDT,EDT,PLIST) ;Find patient list immunizations by CVX code.
+1 NEW CVX,DAS,DATE,DFN,DS,NFOUND
+2 KILL ^TMP($JOB,PLIST)
+3 SET CVX=$PIECE(^AUTTIMM(ITEM,0),U,3)
+4 IF CVX=""
QUIT
+5 SET DS=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+6 SET DFN=0
+7 FOR
SET DFN=$ORDER(^PXRMINDX(9000010.11,"CVX","IP",CVX,DFN))
if DFN=""
QUIT
Begin DoDot:1
+8 SET NFOUND=0
+9 SET DATE=DS
+10 FOR
SET DATE=+$ORDER(^PXRMINDX(9000010.11,"CVX","IP",CVX,DFN,DATE),-1)
if (DATE=0)!(DATE<BDT)!(NFOUND=NOCC)
QUIT
Begin DoDot:2
+11 SET DAS=""
+12 FOR
SET DAS=$ORDER(^PXRMINDX(9000010.11,"CVX","IP",CVX,DFN,DATE,DAS),-1)
if DAS=""
QUIT
Begin DoDot:3
+13 SET NFOUND=NFOUND+1
+14 SET ^TMP($JOB,PLIST,DFN,NFOUND)=DAS_U_DATE
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
+17 ;====================
CVXP(DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient immunizations
+1 ;by CVX code.
+2 NEW CVX,DAS,DATE,DONE,EDTT
+3 SET (DONE,NFOUND)=0
+4 SET CVX=$PIECE(^AUTTIMM(ITEM,0),U,3)
+5 IF CVX=""
QUIT
+6 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+7 SET DATE=$SELECT(SDIR=+1:BDT-.000001,1:EDTT)
+8 FOR
SET DATE=+$ORDER(^PXRMINDX(9000010.11,"CVX","PI",DFN,CVX,DATE),SDIR)
if (DATE=0)!(DONE)
QUIT
Begin DoDot:1
+9 IF DATE<BDT
IF SDIR=-1
SET DONE=1
QUIT
+10 IF DATE>EDTT
IF SDIR=1
SET DONE=1
QUIT
+11 SET DAS=""
+12 FOR
SET DAS=$ORDER(^PXRMINDX(9000010.11,"CVX","PI",DFN,CVX,DATE,DAS),-1)
if DAS=""
QUIT
Begin DoDot:2
+13 SET NFOUND=NFOUND+1
+14 SET FLIST(NFOUND)=DAS_U_DATE
+15 IF NFOUND=NGET
SET DONE=1
QUIT
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
+18 ;====================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate immunization findings.
+1 DO EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL)
+2 QUIT
+3 ;
+4 ;====================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate immunization term findings
+1 ;for patient lists.
+2 DO EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
+3 QUIT
+4 ;
+5 ;====================
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate immunization terms.
+1 DO EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
+2 ;Determine the term's contra/refused status. If all the mapped findings are contra, the status
+3 ;is CONTRA. If all the mapped findings are REFUSED, the status is REFUSED. If a mapped
+4 ;finding is both CONTRA and REFUSED count it as CONTRA. If all the mapped
+5 ;findings are either CONTRA or REFUSED the status is REFUSED.
+6 NEW FINDING,NCONTRA,NF,NPREC,NREFUSED
+7 SET (FINDING,NCONTRA,NF,NPREC,NREFUSED)=0
+8 FOR
SET FINDING=$ORDER(TERMARR(20,FINDING))
if FINDING=""
QUIT
Begin DoDot:1
+9 SET NF=NF+1
+10 IF $GET(TFIEVAL("CONTRA",FINDING))=1
SET NCONTRA=NCONTRA+1
+11 IF $GET(TFIEVAL("PRECAUTION",FINDING))=1
SET NPREC=NPREC+1
+12 IF ($GET(TFIEVAL("CONTRA",FINDING))'=1)
IF ($GET(TFIEVAL("REFUSED",FINDING))=1)
SET NREFUSED=NREFUSED+1
End DoDot:1
+13 IF NCONTRA=NF
SET TFIEVAL("C/R STATUS")="CONTRA"
+14 IF NREFUSED=NF
SET TFIEVAL("C/R STATUS")="REFUSED"
+15 IF (NREFUSED>0)
IF (NCONTRA+NREFUSED)=NF
SET TFIEVAL("C/R STATUS")="REFUSED"
+16 IF '$DATA(TFIEVAL("C/R STATUS"))
IF (NPREC>0)
SET TFIEVAL("C/R STATUS")="PRECAUTION"
+17 QUIT
+18 ;
+19 ;====================
GETDATA(DAS,FIEVT) ;Return data, for a specified V Immunization entry.
+1 DO VIMM^PXPXRM(DAS,.FIEVT,1)
+2 QUIT
+3 ;
+4 ;====================
ISCXHELP(DA,FILENUM) ;Executable help for the Immunization Search Criteria
+1 ;finding modifier.
+2 NEW CVX,DDS,IEN,IMM,IMMIEN,IMMGRP,NLINES,TEXT,VGN,X
+3 SET IMM=$SELECT(FILENUM=811.5:$PIECE(^PXRMD(811.5,DA(1),20,DA,0),U,1),FILENUM=811.9:$PIECE(^PXD(811.9,DA(1),20,DA,0),U,1),1:"")
+4 IF IMM'["AUTTIM"
QUIT
+5 SET IMMIEN=$PIECE(IMM,";",1)
+6 DO IMMGRP^PXAPIIM(.IMMGRP,IMMIEN)
+7 SET NLINES=0
+8 SET CVX=$ORDER(IMMGRP("CVX",""))
+9 SET NLINES=NLINES+1
SET TEXT(NLINES)="Immunizations with the CVX code "_CVX_", are:"
+10 SET IEN=""
+11 FOR
SET IEN=$ORDER(IMMGRP("CVX",CVX,IEN))
if IEN=""
QUIT
Begin DoDot:1
+12 SET NLINES=NLINES+1
SET TEXT(NLINES)=IMMGRP("CVX",CVX,IEN)_" (IEN="_IEN_")"
End DoDot:1
+13 SET VGN=$ORDER(IMMGRP("VG",""))
+14 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+15 IF VGN=""
SET NLINES=NLINES+1
SET TEXT(NLINES)="This immunization is not in a vaccine group."
+16 IF '$TEST
Begin DoDot:1
+17 SET NLINES=NLINES+1
SET TEXT(NLINES)="Immunizations in the vaccine group "_VGN_", are:"
+18 SET IEN=""
+19 FOR
SET IEN=$ORDER(IMMGRP("VG",VGN,IEN))
if IEN=""
QUIT
Begin DoDot:2
+20 SET NLINES=NLINES+1
SET TEXT(NLINES)=IMMGRP("VG",VGN,IEN)_" (IEN="_IEN_")"
End DoDot:2
End DoDot:1
+21 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+22 ;DBIA #5746 covers kill and set of DDS. DDS needs to be set or the
+23 ;Browser will kill some ScreenMan variables.
+24 SET DDS=1
+25 SET X="IORESET"
+26 DO ENDR^%ZISS
+27 DO BROWSE^DDBR("TEXT","NR","Immunization Search Criteria Help")
+28 WRITE IORESET
+29 DO KILL^%ZISS
+30 QUIT
+31 ;
+32 ;====================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output.
+2 NEW EM,FIEN,IND,JND,NAME,NOUT,PNAME,REACTION,SERIES,TEMP,TEXTOUT,VDATE
+3 SET FIEN=$PIECE(IFIEVAL("FINDING"),";",1)
+4 SET PNAME=$PIECE(^AUTTIMM(FIEN,0),U,1)
+5 SET NAME="Immunization: "_PNAME_" = "
+6 SET IND=0
+7 FOR
SET IND=+$ORDER(IFIEVAL(IND))
if IND=0
QUIT
Begin DoDot:1
+8 SET SERIES=$GET(IFIEVAL(IND,"SERIES"))
+9 IF SERIES'=""
SET SERIES=$$EXTERNAL^DILFD(9000010.11,.04,"",SERIES,.EM)
+10 SET VDATE=IFIEVAL(IND,"DATE")
+11 SET TEMP=NAME_SERIES_" ("_$$EDATE^PXRMDATE(VDATE)_")"
+12 DO FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+13 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:1
+14 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+15 QUIT
+16 ;
+17 ;====================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output.
+2 NEW CONREF,CVX,EM,FIEN,IND,INDENTP1,ISC,JND,NOUT,PNAME
+3 NEW REACTION,SERIES,TEMP,TEXTOUT,VDATE,WUDT
+4 SET FIEN=$PIECE(IFIEVAL("FINDING"),";",1)
+5 SET PNAME=$PIECE(^AUTTIMM(FIEN,0),U,1)
+6 SET INDENTP1=INDENT+1
+7 IF INDENT+14+$LENGTH(PNAME)<81
Begin DoDot:1
+8 SET NLINES=NLINES+1
+9 SET TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Immunization: "_PNAME
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 NEW COL1W,COL2W,FMTSTR
+12 SET TEMP="Immunization:^"_PNAME
+13 SET COL1W=INDENT+13
SET COL2W=80-COL1W
+14 SET FMTSTR=COL1W_"R1^"_COL2W_"L"
+15 DO COLFMT^PXRMTEXT(FMTSTR,TEMP," ",.NOUT,.TEXTOUT)
+16 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:1
+17 SET ISC=$GET(IFIEVAL("ISC"))
+18 IF ISC="CVX"
Begin DoDot:1
+19 SET NLINES=NLINES+1
SET TEXT(NLINES)=" CVX search enabled for CVX "_IFIEVAL("CVX")_"."
End DoDot:1
+20 IF ISC="VGN"
Begin DoDot:1
+21 SET TEMP=" Vaccine Group search enabled for vaccine groups:"
+22 SET (JND,IND)=0
+23 FOR
SET IND=+$ORDER(^AUTTIMM(FIEN,7,IND))
if IND=0
QUIT
Begin DoDot:2
+24 SET JND=JND+1
+25 IF JND>1
SET TEMP=TEMP_","
+26 SET TEMP=TEMP_" "_^AUTTIMM(FIEN,7,IND,0)
End DoDot:2
+27 SET TEMP=TEMP_"."
+28 DO FORMATS^PXRMTEXT(INDENTP1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+29 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:1
+30 SET IND=0
+31 FOR
SET IND=+$ORDER(IFIEVAL(IND))
if IND=0
QUIT
Begin DoDot:1
+32 SET VDATE=IFIEVAL(IND,"DATE")
+33 SET TEMP=$$EDATE^PXRMDATE(VDATE)
+34 IF ISC'=""
SET TEMP=TEMP_" "_IFIEVAL(IND,"IMMUNIZATION")
+35 SET REACTION=$GET(IFIEVAL(IND,"REACTION"))
+36 SET SERIES=$GET(IFIEVAL(IND,"SERIES"))
+37 IF SERIES'=""
Begin DoDot:2
+38 SET TEMP=TEMP_" series - "
+39 SET TEMP=TEMP_$$EXTERNAL^DILFD(9000010.11,.04,"",SERIES,.EM)
End DoDot:2
+40 IF REACTION'=""
Begin DoDot:2
+41 SET TEMP=TEMP_" reaction - "
+42 SET TEMP=TEMP_$$EXTERNAL^DILFD(9000010.11,.06,"",REACTION,.EM)
End DoDot:2
+43 DO FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+44 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
+45 IF $GET(IFIEVAL(IND,"COMMENTS"))'=""
Begin DoDot:2
+46 SET TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
+47 DO FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+48 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:2
End DoDot:1
+49 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+50 QUIT
+51 ;
+52 ;====================
OUTPUTCONREF(INDENT,CRTYPE,DEFARR,FIEVAL,NTXT) ;Output contraindication, precaution, and refusal information.
+1 NEW DATE,IEN,JND,FINDING,FINUM,GBL,INDENTP1,NOCC,NLINES,NOUT,PNAME,TEMP,TEXT,TEXTOUT,WUDT
+2 SET PNAME=$SELECT(CRTYPE="CONTRA":"Contraindications",CRTYPE="PRECAUTION":"Precautions",CRTYPE="REFUSED":"Refusals",1:"")
+3 IF PNAME=""
QUIT
+4 SET TEXT(1)=""
SET TEXT(2)=PNAME
+5 DO ADDTXTA^PXRMOUTU(INDENT,PXRMRM,.NTXT,2,.TEXT)
+6 SET INDENTP1=INDENT+1
+7 SET NLINES=0
+8 SET FINUM=""
+9 FOR
SET FINUM=$ORDER(FIEVAL(CRTYPE,FINUM))
if FINUM=""
QUIT
Begin DoDot:1
+10 SET FINDING=$PIECE(DEFARR(20,FINUM,0),U,1)
+11 SET IEN=$PIECE(FINDING,";",1)
+12 SET GBL=$PIECE(FINDING,";",2)
+13 ;If it is not an immunization or term then it is unexpected.
+14 SET PNAME="Unexpected finding :"_FINDING
+15 IF GBL="AUTTIMM("
SET PNAME="Immunization: "_$PIECE(^AUTTIMM(IEN,0),U,1)
+16 IF GBL="PXRMD(811.5,"
SET PNAME="Reminder Term: "_$PIECE(^PXRMD(811.5,IEN,0),U,1)
+17 SET NLINES=NLINES+1
SET TEXT(NLINES)=$$REPEAT^XLFSTR(" ",INDENTP1)_PNAME
+18 SET NOCC=0
+19 FOR
SET NOCC=+$ORDER(FIEVAL(CRTYPE,FINUM,NOCC))
if NOCC=0
QUIT
Begin DoDot:2
+20 SET DATE=FIEVAL(CRTYPE,FINUM,NOCC,"DATE")
+21 SET TEMP=$$EDATE^PXRMDATE(DATE)
+22 SET TEMP=TEMP_" Reason: "_$GET(FIEVAL(CRTYPE,FINUM,NOCC,"REASON"))
+23 SET WUDT=FIEVAL(CRTYPE,FINUM,NOCC,"WUDT")
+24 SET TEMP=TEMP_$SELECT(WUDT=0:", is permanent.",1:", expires "_$$EDATE^PXRMDATE(WUDT)_".")
+25 DO FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+26 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
+27 IF $GET(FIEVAL(CRTYPE,FINUM,NOCC,"COMMENTS"))'=""
Begin DoDot:3
+28 SET TEMP="Comments: "_FIEVAL(CRTYPE,FINUM,"COMMENTS")
+29 DO FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+30 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:3
+31 IF $GET(FIEVAL(CRTYPE,FINUM,NOCC,"GROUP REFUSAL"))'=""
Begin DoDot:3
+32 SET NLINES=NLINES+1
SET TEXT(NLINES)=$$REPEAT^XLFSTR(" ",INDENTP1)_FIEVAL(CRTYPE,FINUM,NOCC,"GROUP REFUSAL")
End DoDot:3
End DoDot:2
End DoDot:1
+33 IF NLINES>0
DO COPYTXT^PXRMOUTU(.NTXT,NLINES,.TEXT)
+34 QUIT
+35 ;
+36 ;====================
TERMCRFINDING(TFIEVAL,FINDING,FIEVAL) ;Save the contraindication, precaution, refusal values of a
+1 ;term. Called from EVALFI^PXRMTERM.
+2 NEW CRTYPE,DATE,DATEORDER,SUB1,SUB2,TFINDING,TYPELIST
+3 ;If a contraindication or refusal was found it is in TFIEVAL("C/R STATUS"),
+4 ;save it to the TYPELIST.
+5 SET TYPELIST(TFIEVAL("C/R STATUS"))=""
+6 ;Add precautions to the TYPELIST so if there are any they will be saved
+7 ;in FIEVAL("PRECAUTION,FINDING). This allows precautions to be displayed
+8 ;in the reminder evaluation output.
+9 SET TYPELIST("PRECAUTION")=""
+10 SET CRTYPE=""
+11 FOR
SET CRTYPE=$ORDER(TYPELIST(CRTYPE))
if CRTYPE=""
QUIT
Begin DoDot:1
+12 IF '$DATA(TFIEVAL(CRTYPE))
QUIT
+13 KILL DATEORDER
+14 SET TFINDING=""
+15 FOR
SET TFINDING=$ORDER(TFIEVAL(CRTYPE,TFINDING))
if TFINDING=""
QUIT
Begin DoDot:2
+16 SET DATE=TFIEVAL(CRTYPE,TFINDING,"DATE")
+17 SET DATEORDER(DATE,TFINDING)=""
End DoDot:2
+18 ;Save the term finding with the most recent date as
+19 ;value of the finding.
+20 SET DATE=$ORDER(DATEORDER(""),-1)
+21 SET TFINDING=$ORDER(DATEORDER(DATE,""))
+22 SET FIEVAL(CRTYPE,FINDING)=TFIEVAL(CRTYPE,TFINDING)
+23 ;Save the rest of the term into the finding.
+24 SET DATE=""
+25 FOR
SET DATE=$ORDER(DATEORDER(DATE),-1)
if DATE=""
QUIT
Begin DoDot:2
+26 SET TFINDING=""
+27 FOR
SET TFINDING=$ORDER(DATEORDER(DATE,TFINDING))
if TFINDING=""
QUIT
Begin DoDot:3
+28 SET SUB1=""
+29 FOR
SET SUB1=$ORDER(TFIEVAL(CRTYPE,TFINDING,SUB1))
if SUB1=""
QUIT
Begin DoDot:4
+30 IF +SUB1=0
SET FIEVAL(CRTYPE,FINDING,SUB1)=TFIEVAL(CRTYPE,TFINDING,SUB1)
QUIT
+31 SET SUB2=""
+32 FOR
SET SUB2=$ORDER(TFIEVAL(CRTYPE,TFINDING,SUB1,SUB2))
if SUB2=""
QUIT
Begin DoDot:5
+33 SET FIEVAL(CRTYPE,FINDING,SUB1,SUB2)=TFIEVAL(CRTYPE,TFINDING,SUB1,SUB2)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+34 QUIT
+35 ;
+36 ;====================
VGNL(ITEM,NOCC,BDT,EDT,PLIST) ;Find patient list immunizations by Vaccine
+1 ;Group Names.
+2 NEW DAS,DATE,DFN,DS,IMM,IND,NFOUND,VGN,VGNL
+3 KILL ^TMP($JOB,PLIST)
+4 IF '$DATA(^AUTTIMM(ITEM,7))
QUIT
+5 SET DS=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+6 ;Build the list of immunizations based on the vaccine groups.
+7 SET IND=0
+8 FOR
SET IND=+$ORDER(^AUTTIMM(ITEM,7,IND))
if IND=0
QUIT
Begin DoDot:1
+9 SET VGN=^AUTTIMM(ITEM,7,IND,0)
+10 MERGE VGNL=^AUTTIMM("I",VGN)
End DoDot:1
+11 SET IMM=""
+12 FOR
SET IMM=$ORDER(VGNL(IMM))
if IMM=""
QUIT
Begin DoDot:1
+13 SET DFN=0
+14 FOR
SET DFN=$ORDER(^PXRMINDX(9000010.11,"IP",IMM,DFN))
if DFN=""
QUIT
Begin DoDot:2
+15 SET NFOUND=0
+16 SET DATE=DS
+17 FOR
SET DATE=+$ORDER(^PXRMINDX(9000010.11,"IP",IMM,DFN,DATE),-1)
if (DATE=0)!(DATE<BDT)!(NFOUND=NOCC)
QUIT
Begin DoDot:3
+18 SET DAS=""
+19 FOR
SET DAS=$ORDER(^PXRMINDX(9000010.11,"IP",IMM,DFN,DATE,DAS),-1)
if DAS=""
QUIT
Begin DoDot:4
+20 SET NFOUND=NFOUND+1
+21 SET ^TMP($JOB,PLIST,DFN,NFOUND)=DAS_U_DATE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
+24 ;====================
VGNP(DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient immunizations
+1 ;by Vaccine Group Names.
+2 NEW DAS,DATE,DONE,DS,EDTT,IMM,IND,VGN,VGNL
+3 SET (DONE,NFOUND)=0
+4 IF '$DATA(^AUTTIMM(ITEM,7))
QUIT
+5 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+6 SET DS=$SELECT(SDIR=+1:BDT-.000001,1:EDTT)
+7 ;Build the list of immunizations based on the vaccine groups.
+8 SET IND=0
+9 FOR
SET IND=+$ORDER(^AUTTIMM(ITEM,7,IND))
if IND=0
QUIT
Begin DoDot:1
+10 SET VGN=^AUTTIMM(ITEM,7,IND,0)
+11 MERGE VGNL=^AUTTIMM("I",VGN)
End DoDot:1
+12 SET IMM=""
+13 FOR
SET IMM=$ORDER(VGNL(IMM))
if IMM=""
QUIT
Begin DoDot:1
+14 SET DATE=DS
+15 FOR
SET DATE=+$ORDER(^PXRMINDX(9000010.11,"PI",DFN,IMM,DATE),SDIR)
if (DATE=0)!(DONE)
QUIT
Begin DoDot:2
+16 IF DATE<BDT
IF SDIR=-1
SET DONE=1
QUIT
+17 IF DATE>EDTT
IF SDIR=1
SET DONE=1
QUIT
+18 SET DAS=""
+19 FOR
SET DAS=$ORDER(^PXRMINDX(9000010.11,"PI",DFN,IMM,DATE,DAS),-1)
if DAS=""
QUIT
Begin DoDot:3
+20 SET NFOUND=NFOUND+1
+21 SET FLIST(NFOUND)=DAS_U_DATE
+22 IF NFOUND=NGET
SET DONE=1
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
