PXVRPC5 ;BPFO/LMT - PCE RPCs for Imm Contraindications/refusals ;Aug 10, 2021@15:21:58
;;1.0;PCE PATIENT CARE ENCOUNTER;**215,216,217**;Aug 12, 1996;Build 134
;
;
GETICR(PXRSLT,PXFILE,PXFLTR,PXINST,PXLOC) ;
;
; Returns entries from the IMM CONTRAINDICATION REASONS (#920.4) and
; IMM REFUSAL REASONS (#920.5) files.
;
;Input:
; PXRSLT - Return value passed by reference (Required)
; PXFILE - Which file to pull from (Optional; Leave this null to pull entries from both files)
; Possible values are:
; "920.4" - Only return entries from IMM CONTRAINDICATION REASONS (#920.4)
; "920.5" - Only return entries from IMM REFUSAL REASONS (#920.5)
; PXFLTR - Filter (Optional; Defaults to "S:A")
; Possible values are:
; R:X - Return entry with IEN X (PXFILE must be passed in with this option).
; C:X^Y - Return entry with Concept Code^Coding System X^Y (used only for #920.4).
; H:X - Return entry with HL7 Code X (used only for #920.5).
; N:X - Return entry with #.01 field equal to X
; I:X - Return all active entries that are selectable for Immunization IEN X.
; S:A - Return all active entries.
; S:I - Return all inactive entries.
; S:B - Return all entries (both active and inactive).
; PXINST - Institution IEN
; PXLOC - Location IEN (If Institution IEN is not passed in, the loc will be used to get the institution).
;
;Returns:
; PXRSLT(0)=Count of elements returned (0 if nothing found)
; For 920.4 Entry:
; PXRSLT(n)=IEN;PXV(920.4,^Name^Status (1:Active, 0:Inactive)^Code|Coding System^NIP004
; ^Contraindication/Precaution^Allergy-Related (1:Yes, 0:No)^Default Warn Until Date ("Forever" means it should be forever)
; For 920.5 Entry:
; PXRSLT(n)=IEN;PXV(920.5,^Name^Status (1:Active, 0:Inactive)^HL7 Code^Default Warn Until Date ("Forever" means it should be forever)
;
N PXCNT,PXCODE,PXFILES,PXFLTRTYP,PXFLTRVAL,PXI,PXIEN,PXNAME,PXPAR,PXSEQARR,PXSKIP,PXSYS,PXX
;
I $G(PXFILE)'?1(1"920.4",1"920.5") S PXFILE=""
I $P($G(PXFLTR),":",1)'?1(1"R",1"C",1"H",1"N",1"I",1"S") S PXFLTR="S:A"
I $G(PXINST)="",$G(PXLOC) S PXINST=$$INST^PXVUTIL("L:"_+PXLOC)
I '$G(PXINST) S PXINST=$$KSP^XUPARAM("INST")
S PXCNT=0
S PXFLTRTYP=$P(PXFLTR,":",1)
S PXFLTRVAL=$P(PXFLTR,":",2)
D CHKCACHE^PXVRPC2(920.5)
;
I PXFLTRTYP="R" D
. I 'PXFILE Q
. S PXIEN=PXFLTRVAL
. I 'PXIEN Q
. I '$D(^PXV(PXFILE,PXIEN)) Q
. D ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,"","",.PXCNT,PXINST)
;
I PXFLTRTYP="C" D
. S PXFILE=920.4
. S PXCODE=$P(PXFLTRVAL,U,1)
. S PXSYS=$P(PXFLTRVAL,U,2)
. I (PXCODE="")!(PXSYS="") Q
. S PXIEN=0
. S PXX=0
. F S PXX=$O(^PXV(PXFILE,"C",PXCODE,PXX)) Q:'PXX D Q:PXIEN
. . I $P($G(^PXV(PXFILE,PXX,"VUID")),U,4)=PXSYS S PXIEN=PXX
. I 'PXIEN Q
. D ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,"","",.PXCNT,PXINST)
;
I PXFLTRTYP="H" D
. S PXFILE=920.5
. I PXFLTRVAL="" Q
. S PXIEN=0
. S PXX=0
. F S PXX=$O(^PXV(PXFILE,PXX)) Q:'PXX D Q:PXIEN
. . I $P($G(^PXV(PXFILE,PXX,0)),U,2)=PXFLTRVAL S PXIEN=PXX
. I 'PXIEN Q
. D ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,"","",.PXCNT,PXINST)
;
I PXFILE="" D
. S PXFILES(920.4)=""
. S PXFILES(920.5)=""
I PXFILE'="" S PXFILES(PXFILE)=""
;
I PXFLTRTYP="N" D
. I PXFLTRVAL="" Q
. S PXIEN=0
. S PXFILE=0
. F S PXFILE=$O(PXFILES(PXFILE)) Q:'PXFILE D Q:PXIEN
. . S PXIEN=$O(^PXV(PXFILE,"B",PXFLTRVAL,0))
. I 'PXIEN Q
. D ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,"","",.PXCNT,PXINST)
;
I PXFLTRTYP?1(1"S",1"I") D
. S PXFILE=0
. F S PXFILE=$O(PXFILES(PXFILE)) Q:'PXFILE D
. . ;
. . ; Sort entries based off the order defined in the parameter
. . S PXPAR=$S(PXFILE=920.4:"PXV CONTRA SEQUENCE",1:"PXV REFUSAL SEQUENCE")
. . K PXSEQARR
. . D GETLST^XPAR(.PXSEQARR,"ALL",PXPAR,"Q")
. . S PXI=0 F S PXI=$O(PXSEQARR(PXI)) Q:'PXI D
. . . S PXIEN=$P($G(PXSEQARR(PXI)),U,2)
. . . I 'PXIEN Q
. . . D ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,.PXFLTRTYP,.PXFLTRVAL,.PXCNT,PXINST)
. . . S PXSKIP(PXFILE,PXIEN)=""
. . ;
. . ; Sort remaining entries in alphabetical order
. . S PXNAME=""
. . F S PXNAME=$O(^PXV(PXFILE,"B",PXNAME)) Q:PXNAME="" D
. . . S PXIEN=0
. . . F S PXIEN=$O(^PXV(PXFILE,"B",PXNAME,PXIEN)) Q:'PXIEN D
. . . . I $D(PXSKIP(PXFILE,PXIEN)) Q
. . . . D ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,PXFLTRTYP,PXFLTRVAL,.PXCNT,PXINST)
;
S PXRSLT(0)=PXCNT
;
Q
;
ADDENTRY(PXRSLT,PXFILE,PXIEN,PXFLTRTYP,PXFLTRVAL,PXCNT,PXINST) ; Adds entry to PXVRSLT
;
N PXFLDS,PXFLTRSTAT,PXSKIP,PXSTAT,PXWARNDATE
;
I 'PXIEN Q
;
S PXSKIP=0
I PXFILE=920.4,$G(PXFLTRTYP)="I",$G(PXFLTRVAL),$O(^PXV(PXFILE,PXIEN,3,0)) D
. I '$O(^PXV(PXFILE,PXIEN,3,"B",PXFLTRVAL,0)) S PXSKIP=1
I PXSKIP Q
;
S PXFLDS=$$GETFLDS(PXFILE,PXIEN,PXINST)
S PXSTAT=$P(PXFLDS,U,3)
S PXWARNDATE=$P(PXFLDS,U,$S(PXFILE=920.5:5,1:8))
;
S PXFLTRSTAT="A"
I $G(PXFLTRTYP)="S",$G(PXFLTRVAL)?1(1"A",1"I",1"B") S PXFLTRSTAT=PXFLTRVAL
I $G(PXFLTRSTAT)="A",'PXSTAT Q
I $G(PXFLTRSTAT)="I",PXSTAT Q
;
; Don't include this entry if no default warn until day is defined for it.
I $G(PXFLTRSTAT)="A",PXWARNDATE="" Q
;
S PXCNT=PXCNT+1
S PXRSLT(PXCNT)=PXFLDS
;
Q
;
GETFLDS(PXFILE,PXIEN,PXINST) ; Returns field values
;
N PXCODE,PXNAME,PXNODE,PXRSLT,PXSTAT,PXWARNDT
;
S PXNODE=$G(^PXV(PXFILE,PXIEN,0))
S PXNAME=$P(PXNODE,U,1)
S PXCODE=$P(PXNODE,U,2)
S PXSTAT=$$GETSTAT^PXVRPC2(PXFILE,PXIEN)
;
S PXRSLT=PXIEN_";PXV("_PXFILE_","_U_PXNAME_U_PXSTAT_U_PXCODE
;
I PXFILE=920.4 D
. S PXRSLT=PXRSLT_"|"_$P($G(^PXV(PXFILE,PXIEN,"VUID")),U,4)
. S PXRSLT=PXRSLT_U_$P(PXNODE,U,4)_U_$P(PXNODE,U,5)
. S PXRSLT=PXRSLT_U_$$ARTAPI^PXVUTIL(PXIEN)
;
D CONDEF(.PXWARNDT,PXIEN_";PXV("_PXFILE_",",PXINST)
S PXRSLT=PXRSLT_U_$G(PXWARNDT)
;
Q PXRSLT
;
GETVICR(PXRSLT,DFN,PXVIMM,PXDATE,PXFORMAT) ;
;
; Returns "active" entries from the V IMM CONTRA/REFUSAL EVENTS file (#9000010.707)
; that are related to the given patient and immunization.
; "Active" is defined as entries where the Event Date and Time is <= PXDATE@24
; and the Warn Until Date is null or >= PXDATE.
;
;Input:
; PXRSLT - Return value passed by reference (Required)
; DFN - Pointer to file #2 (Required)
; PXVIMM - Pointer to #9999999.14 (Required)
; PXDATE - Date (without time) Used to determine if entry is "active"
; (Optional; Defaults to TODAY)
; PXFORMAT - Format that return array should be returned (Optional; Defaults to "L")
; Possible values are:
; "L": Return a caret-delimited list of entries
; "W": Returns a warning message.
;
;Returns:
; PXRSLT(0)=Count of elements returned (0 if nothing found)
; If PXFORMAT="L":
; PXRSLT(n)="VICR" ^ V IMM Contra/Refusal Events IEN ^ Visit IEN ^ Contra/Refusal
; variable pointer | Contra/Refusal Name ^ Immunization IEN | Name
; ^ Warn Until Date ^ D/T Recorded ^ Event D/T ^ Encounter Provider
; IEN | Name
; PXRSLT(n)="COM" ^ Comments
; If PXFORMAT["W":
; PXRSLT(n)=Warning text
;
N PXCNT,PXEDATE,PXICRARR,PXIEN,PXSDATE,PXCONTRA,PXNODE,PXSORT,PXVIEN
;
I (('$G(DFN))!('$G(PXVIMM))) S PXRSLT(0)=0 Q
;
I '$G(PXDATE) S PXDATE=DT
S PXSDATE=$P(PXDATE,".",1)
S PXEDATE=9999999
I PXSDATE'=DT S PXEDATE=PXSDATE_".24"
I $G(PXFORMAT)'?1(1"W",1"L") S PXFORMAT="L"
;
D PATICR^PXAPIIM(.PXICRARR,$G(DFN),$G(PXVIMM),PXSDATE,PXEDATE)
S PXCNT=0
;
I PXFORMAT="W",$O(PXICRARR(0)) D
. S PXCNT=PXCNT+1
. S PXRSLT(PXCNT)="Warning: Contraindication/refusal event(s) associated with this immunization:"
;
S PXIEN=0
F S PXIEN=$O(PXICRARR(PXIEN)) Q:'PXIEN D
. S PXNODE=$G(PXICRARR(PXIEN))
. S PXVIEN=$P($P(PXNODE,U,2),"|",1)
. S PXCONTRA=$G(PXICRARR(PXIEN,"CONTRAINDICATION/PRECAUTION"))
. ; PXSORT: 1 - Contraindications); 2 - Precautions; 3 - Refusals
. S PXSORT=$S($P(PXVIEN,";",2)[920.5:3,PXCONTRA="C":1,PXCONTRA="P":2,1:2)
. S PXSORT(PXSORT,PXIEN)=""
F PXSORT=1:1:3 D
. S PXIEN=0
. F S PXIEN=$O(PXSORT(PXSORT,PXIEN)) Q:'PXIEN D
. . D ADDVICR(.PXRSLT,.PXICRARR,.PXIEN,.PXCNT,.PXFORMAT)
;
S PXRSLT(0)=PXCNT
;
Q
;
ADDVICR(PXRSLT,PXICRARR,PXIEN,PXCNT,PXFORMAT) ; Add one entry to PXRSLT
;
N PXNODE,PXWARNDT,PXX,PXVIEN,PXTITLE
;
I PXFORMAT="L" D
. S PXCNT=PXCNT+1
. S PXRSLT(PXCNT)="VICR"_U_PXIEN_U_$G(PXICRARR(PXIEN))
. I $G(PXICRARR(PXIEN,"COMMENTS"))'="" D
. . S PXCNT=PXCNT+1
. . S PXRSLT(PXCNT)="COM"_U_$G(PXICRARR(PXIEN,"COMMENTS"))
;
I PXFORMAT="W" D
. S PXNODE=$G(PXICRARR(PXIEN))
. S PXVIEN=$P($P(PXNODE,U,2),"|",1)
. S PXTITLE=$S($P(PXVIEN,";",2)[920.5:"Patient Refused",1:$G(PXICRARR(PXIEN,"CONTRAINDICATION/PRECAUTION")))
. S PXTITLE=$S(PXTITLE="C":"Contraindicated",PXTITLE="P":"Precaution",1:PXTITLE)
. S PXX="- "_PXTITLE_": "
. S PXX=PXX_$P($P(PXNODE,U,2),"|",2)
. S PXWARNDT=$P(PXNODE,U,4)
. I PXWARNDT S PXX=PXX_" (Until "_$$FMTE^XLFDT(PXWARNDT,1)_")"
. S PXCNT=PXCNT+1
. S PXRSLT(PXCNT)=" "
. S PXCNT=PXCNT+1
. S PXRSLT(PXCNT)=PXX
. I $G(PXICRARR(PXIEN,"COMMENTS"))'="" D
. . S PXX=" Comment: "_PXICRARR(PXIEN,"COMMENTS")
. . S PXCNT=PXCNT+1
. . S PXRSLT(PXCNT)=PXX
;
Q
;
;
CONDEF(PXRSLT,PXENTRY,PXINST) ;
;
N PXDAYS,PXIEN,PXIEN2,PXPRNT,PXSTA
;
S PXRSLT=""
;
I '$G(PXENTRY)!('$G(PXINST)) Q
I $D(PXINST(PXINST)) Q ; Used to prevent infinite recursion
;
S PXIEN=$O(^PXV(920.05,"AD",PXINST,PXENTRY,0))
;
I PXIEN D
. S PXIEN2=$O(^PXV(920.05,"AD",PXINST,PXENTRY,PXIEN,0))
. I 'PXIEN2 S PXIEN="" Q
. S PXDAYS=$P($G(^PXV(920.05,PXIEN,2,PXIEN2,0)),U,2)
. I PXDAYS="" S PXIEN="" Q
. I PXDAYS=0 S PXRSLT="FOREVER"
. I PXDAYS>0 S PXRSLT=$$FMADD^XLFDT(DT,PXDAYS)
;
; If site did not create defaults, make recursive
; call for parent Institution; if parent has defaults,
; inherit from parent.
I 'PXIEN D
. S PXSTA=$$STA^XUAF4(PXINST)
. I PXSTA="" Q
. S PXPRNT=$$PRNT^XUAF4(PXSTA)
. ;
. ; If parent = self, we reached the top of the chain
. I $P(PXPRNT,U,2)=PXSTA Q
. I (+PXPRNT)=PXINST Q
. I 'PXPRNT Q
. ;
. ; Used to prevent infinite recursion
. S PXINST(PXINST)=""
. ;
. S PXINST=+PXPRNT
. D CONDEF(.PXRSLT,PXENTRY,.PXINST)
;
Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXVRPC5 10440 printed Sep 23, 2025@20:08:03 Page 2
PXVRPC5 ;BPFO/LMT - PCE RPCs for Imm Contraindications/refusals ;Aug 10, 2021@15:21:58
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**215,216,217**;Aug 12, 1996;Build 134
+2 ;
+3 ;
GETICR(PXRSLT,PXFILE,PXFLTR,PXINST,PXLOC) ;
+1 ;
+2 ; Returns entries from the IMM CONTRAINDICATION REASONS (#920.4) and
+3 ; IMM REFUSAL REASONS (#920.5) files.
+4 ;
+5 ;Input:
+6 ; PXRSLT - Return value passed by reference (Required)
+7 ; PXFILE - Which file to pull from (Optional; Leave this null to pull entries from both files)
+8 ; Possible values are:
+9 ; "920.4" - Only return entries from IMM CONTRAINDICATION REASONS (#920.4)
+10 ; "920.5" - Only return entries from IMM REFUSAL REASONS (#920.5)
+11 ; PXFLTR - Filter (Optional; Defaults to "S:A")
+12 ; Possible values are:
+13 ; R:X - Return entry with IEN X (PXFILE must be passed in with this option).
+14 ; C:X^Y - Return entry with Concept Code^Coding System X^Y (used only for #920.4).
+15 ; H:X - Return entry with HL7 Code X (used only for #920.5).
+16 ; N:X - Return entry with #.01 field equal to X
+17 ; I:X - Return all active entries that are selectable for Immunization IEN X.
+18 ; S:A - Return all active entries.
+19 ; S:I - Return all inactive entries.
+20 ; S:B - Return all entries (both active and inactive).
+21 ; PXINST - Institution IEN
+22 ; PXLOC - Location IEN (If Institution IEN is not passed in, the loc will be used to get the institution).
+23 ;
+24 ;Returns:
+25 ; PXRSLT(0)=Count of elements returned (0 if nothing found)
+26 ; For 920.4 Entry:
+27 ; PXRSLT(n)=IEN;PXV(920.4,^Name^Status (1:Active, 0:Inactive)^Code|Coding System^NIP004
+28 ; ^Contraindication/Precaution^Allergy-Related (1:Yes, 0:No)^Default Warn Until Date ("Forever" means it should be forever)
+29 ; For 920.5 Entry:
+30 ; PXRSLT(n)=IEN;PXV(920.5,^Name^Status (1:Active, 0:Inactive)^HL7 Code^Default Warn Until Date ("Forever" means it should be forever)
+31 ;
+32 NEW PXCNT,PXCODE,PXFILES,PXFLTRTYP,PXFLTRVAL,PXI,PXIEN,PXNAME,PXPAR,PXSEQARR,PXSKIP,PXSYS,PXX
+33 ;
+34 IF $GET(PXFILE)'?1(1"920.4",1"920.5")
SET PXFILE=""
+35 IF $PIECE($GET(PXFLTR),":",1)'?1(1"R",1"C",1"H",1"N",1"I",1"S")
SET PXFLTR="S:A"
+36 IF $GET(PXINST)=""
IF $GET(PXLOC)
SET PXINST=$$INST^PXVUTIL("L:"_+PXLOC)
+37 IF '$GET(PXINST)
SET PXINST=$$KSP^XUPARAM("INST")
+38 SET PXCNT=0
+39 SET PXFLTRTYP=$PIECE(PXFLTR,":",1)
+40 SET PXFLTRVAL=$PIECE(PXFLTR,":",2)
+41 DO CHKCACHE^PXVRPC2(920.5)
+42 ;
+43 IF PXFLTRTYP="R"
Begin DoDot:1
+44 IF 'PXFILE
QUIT
+45 SET PXIEN=PXFLTRVAL
+46 IF 'PXIEN
QUIT
+47 IF '$DATA(^PXV(PXFILE,PXIEN))
QUIT
+48 DO ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,"","",.PXCNT,PXINST)
End DoDot:1
+49 ;
+50 IF PXFLTRTYP="C"
Begin DoDot:1
+51 SET PXFILE=920.4
+52 SET PXCODE=$PIECE(PXFLTRVAL,U,1)
+53 SET PXSYS=$PIECE(PXFLTRVAL,U,2)
+54 IF (PXCODE="")!(PXSYS="")
QUIT
+55 SET PXIEN=0
+56 SET PXX=0
+57 FOR
SET PXX=$ORDER(^PXV(PXFILE,"C",PXCODE,PXX))
if 'PXX
QUIT
Begin DoDot:2
+58 IF $PIECE($GET(^PXV(PXFILE,PXX,"VUID")),U,4)=PXSYS
SET PXIEN=PXX
End DoDot:2
if PXIEN
QUIT
+59 IF 'PXIEN
QUIT
+60 DO ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,"","",.PXCNT,PXINST)
End DoDot:1
+61 ;
+62 IF PXFLTRTYP="H"
Begin DoDot:1
+63 SET PXFILE=920.5
+64 IF PXFLTRVAL=""
QUIT
+65 SET PXIEN=0
+66 SET PXX=0
+67 FOR
SET PXX=$ORDER(^PXV(PXFILE,PXX))
if 'PXX
QUIT
Begin DoDot:2
+68 IF $PIECE($GET(^PXV(PXFILE,PXX,0)),U,2)=PXFLTRVAL
SET PXIEN=PXX
End DoDot:2
if PXIEN
QUIT
+69 IF 'PXIEN
QUIT
+70 DO ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,"","",.PXCNT,PXINST)
End DoDot:1
+71 ;
+72 IF PXFILE=""
Begin DoDot:1
+73 SET PXFILES(920.4)=""
+74 SET PXFILES(920.5)=""
End DoDot:1
+75 IF PXFILE'=""
SET PXFILES(PXFILE)=""
+76 ;
+77 IF PXFLTRTYP="N"
Begin DoDot:1
+78 IF PXFLTRVAL=""
QUIT
+79 SET PXIEN=0
+80 SET PXFILE=0
+81 FOR
SET PXFILE=$ORDER(PXFILES(PXFILE))
if 'PXFILE
QUIT
Begin DoDot:2
+82 SET PXIEN=$ORDER(^PXV(PXFILE,"B",PXFLTRVAL,0))
End DoDot:2
if PXIEN
QUIT
+83 IF 'PXIEN
QUIT
+84 DO ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,"","",.PXCNT,PXINST)
End DoDot:1
+85 ;
+86 IF PXFLTRTYP?1(1"S",1"I")
Begin DoDot:1
+87 SET PXFILE=0
+88 FOR
SET PXFILE=$ORDER(PXFILES(PXFILE))
if 'PXFILE
QUIT
Begin DoDot:2
+89 ;
+90 ; Sort entries based off the order defined in the parameter
+91 SET PXPAR=$SELECT(PXFILE=920.4:"PXV CONTRA SEQUENCE",1:"PXV REFUSAL SEQUENCE")
+92 KILL PXSEQARR
+93 DO GETLST^XPAR(.PXSEQARR,"ALL",PXPAR,"Q")
+94 SET PXI=0
FOR
SET PXI=$ORDER(PXSEQARR(PXI))
if 'PXI
QUIT
Begin DoDot:3
+95 SET PXIEN=$PIECE($GET(PXSEQARR(PXI)),U,2)
+96 IF 'PXIEN
QUIT
+97 DO ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,.PXFLTRTYP,.PXFLTRVAL,.PXCNT,PXINST)
+98 SET PXSKIP(PXFILE,PXIEN)=""
End DoDot:3
+99 ;
+100 ; Sort remaining entries in alphabetical order
+101 SET PXNAME=""
+102 FOR
SET PXNAME=$ORDER(^PXV(PXFILE,"B",PXNAME))
if PXNAME=""
QUIT
Begin DoDot:3
+103 SET PXIEN=0
+104 FOR
SET PXIEN=$ORDER(^PXV(PXFILE,"B",PXNAME,PXIEN))
if 'PXIEN
QUIT
Begin DoDot:4
+105 IF $DATA(PXSKIP(PXFILE,PXIEN))
QUIT
+106 DO ADDENTRY(.PXRSLT,.PXFILE,.PXIEN,PXFLTRTYP,PXFLTRVAL,.PXCNT,PXINST)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+107 ;
+108 SET PXRSLT(0)=PXCNT
+109 ;
+110 QUIT
+111 ;
ADDENTRY(PXRSLT,PXFILE,PXIEN,PXFLTRTYP,PXFLTRVAL,PXCNT,PXINST) ; Adds entry to PXVRSLT
+1 ;
+2 NEW PXFLDS,PXFLTRSTAT,PXSKIP,PXSTAT,PXWARNDATE
+3 ;
+4 IF 'PXIEN
QUIT
+5 ;
+6 SET PXSKIP=0
+7 IF PXFILE=920.4
IF $GET(PXFLTRTYP)="I"
IF $GET(PXFLTRVAL)
IF $ORDER(^PXV(PXFILE,PXIEN,3,0))
Begin DoDot:1
+8 IF '$ORDER(^PXV(PXFILE,PXIEN,3,"B",PXFLTRVAL,0))
SET PXSKIP=1
End DoDot:1
+9 IF PXSKIP
QUIT
+10 ;
+11 SET PXFLDS=$$GETFLDS(PXFILE,PXIEN,PXINST)
+12 SET PXSTAT=$PIECE(PXFLDS,U,3)
+13 SET PXWARNDATE=$PIECE(PXFLDS,U,$SELECT(PXFILE=920.5:5,1:8))
+14 ;
+15 SET PXFLTRSTAT="A"
+16 IF $GET(PXFLTRTYP)="S"
IF $GET(PXFLTRVAL)?1(1"A",1"I",1"B")
SET PXFLTRSTAT=PXFLTRVAL
+17 IF $GET(PXFLTRSTAT)="A"
IF 'PXSTAT
QUIT
+18 IF $GET(PXFLTRSTAT)="I"
IF PXSTAT
QUIT
+19 ;
+20 ; Don't include this entry if no default warn until day is defined for it.
+21 IF $GET(PXFLTRSTAT)="A"
IF PXWARNDATE=""
QUIT
+22 ;
+23 SET PXCNT=PXCNT+1
+24 SET PXRSLT(PXCNT)=PXFLDS
+25 ;
+26 QUIT
+27 ;
GETFLDS(PXFILE,PXIEN,PXINST) ; Returns field values
+1 ;
+2 NEW PXCODE,PXNAME,PXNODE,PXRSLT,PXSTAT,PXWARNDT
+3 ;
+4 SET PXNODE=$GET(^PXV(PXFILE,PXIEN,0))
+5 SET PXNAME=$PIECE(PXNODE,U,1)
+6 SET PXCODE=$PIECE(PXNODE,U,2)
+7 SET PXSTAT=$$GETSTAT^PXVRPC2(PXFILE,PXIEN)
+8 ;
+9 SET PXRSLT=PXIEN_";PXV("_PXFILE_","_U_PXNAME_U_PXSTAT_U_PXCODE
+10 ;
+11 IF PXFILE=920.4
Begin DoDot:1
+12 SET PXRSLT=PXRSLT_"|"_$PIECE($GET(^PXV(PXFILE,PXIEN,"VUID")),U,4)
+13 SET PXRSLT=PXRSLT_U_$PIECE(PXNODE,U,4)_U_$PIECE(PXNODE,U,5)
+14 SET PXRSLT=PXRSLT_U_$$ARTAPI^PXVUTIL(PXIEN)
End DoDot:1
+15 ;
+16 DO CONDEF(.PXWARNDT,PXIEN_";PXV("_PXFILE_",",PXINST)
+17 SET PXRSLT=PXRSLT_U_$GET(PXWARNDT)
+18 ;
+19 QUIT PXRSLT
+20 ;
GETVICR(PXRSLT,DFN,PXVIMM,PXDATE,PXFORMAT) ;
+1 ;
+2 ; Returns "active" entries from the V IMM CONTRA/REFUSAL EVENTS file (#9000010.707)
+3 ; that are related to the given patient and immunization.
+4 ; "Active" is defined as entries where the Event Date and Time is <= PXDATE@24
+5 ; and the Warn Until Date is null or >= PXDATE.
+6 ;
+7 ;Input:
+8 ; PXRSLT - Return value passed by reference (Required)
+9 ; DFN - Pointer to file #2 (Required)
+10 ; PXVIMM - Pointer to #9999999.14 (Required)
+11 ; PXDATE - Date (without time) Used to determine if entry is "active"
+12 ; (Optional; Defaults to TODAY)
+13 ; PXFORMAT - Format that return array should be returned (Optional; Defaults to "L")
+14 ; Possible values are:
+15 ; "L": Return a caret-delimited list of entries
+16 ; "W": Returns a warning message.
+17 ;
+18 ;Returns:
+19 ; PXRSLT(0)=Count of elements returned (0 if nothing found)
+20 ; If PXFORMAT="L":
+21 ; PXRSLT(n)="VICR" ^ V IMM Contra/Refusal Events IEN ^ Visit IEN ^ Contra/Refusal
+22 ; variable pointer | Contra/Refusal Name ^ Immunization IEN | Name
+23 ; ^ Warn Until Date ^ D/T Recorded ^ Event D/T ^ Encounter Provider
+24 ; IEN | Name
+25 ; PXRSLT(n)="COM" ^ Comments
+26 ; If PXFORMAT["W":
+27 ; PXRSLT(n)=Warning text
+28 ;
+29 NEW PXCNT,PXEDATE,PXICRARR,PXIEN,PXSDATE,PXCONTRA,PXNODE,PXSORT,PXVIEN
+30 ;
+31 IF (('$GET(DFN))!('$GET(PXVIMM)))
SET PXRSLT(0)=0
QUIT
+32 ;
+33 IF '$GET(PXDATE)
SET PXDATE=DT
+34 SET PXSDATE=$PIECE(PXDATE,".",1)
+35 SET PXEDATE=9999999
+36 IF PXSDATE'=DT
SET PXEDATE=PXSDATE_".24"
+37 IF $GET(PXFORMAT)'?1(1"W",1"L")
SET PXFORMAT="L"
+38 ;
+39 DO PATICR^PXAPIIM(.PXICRARR,$GET(DFN),$GET(PXVIMM),PXSDATE,PXEDATE)
+40 SET PXCNT=0
+41 ;
+42 IF PXFORMAT="W"
IF $ORDER(PXICRARR(0))
Begin DoDot:1
+43 SET PXCNT=PXCNT+1
+44 SET PXRSLT(PXCNT)="Warning: Contraindication/refusal event(s) associated with this immunization:"
End DoDot:1
+45 ;
+46 SET PXIEN=0
+47 FOR
SET PXIEN=$ORDER(PXICRARR(PXIEN))
if 'PXIEN
QUIT
Begin DoDot:1
+48 SET PXNODE=$GET(PXICRARR(PXIEN))
+49 SET PXVIEN=$PIECE($PIECE(PXNODE,U,2),"|",1)
+50 SET PXCONTRA=$GET(PXICRARR(PXIEN,"CONTRAINDICATION/PRECAUTION"))
+51 ; PXSORT: 1 - Contraindications); 2 - Precautions; 3 - Refusals
+52 SET PXSORT=$SELECT($PIECE(PXVIEN,";",2)[920.5:3,PXCONTRA="C":1,PXCONTRA="P":2,1:2)
+53 SET PXSORT(PXSORT,PXIEN)=""
End DoDot:1
+54 FOR PXSORT=1:1:3
Begin DoDot:1
+55 SET PXIEN=0
+56 FOR
SET PXIEN=$ORDER(PXSORT(PXSORT,PXIEN))
if 'PXIEN
QUIT
Begin DoDot:2
+57 DO ADDVICR(.PXRSLT,.PXICRARR,.PXIEN,.PXCNT,.PXFORMAT)
End DoDot:2
End DoDot:1
+58 ;
+59 SET PXRSLT(0)=PXCNT
+60 ;
+61 QUIT
+62 ;
ADDVICR(PXRSLT,PXICRARR,PXIEN,PXCNT,PXFORMAT) ; Add one entry to PXRSLT
+1 ;
+2 NEW PXNODE,PXWARNDT,PXX,PXVIEN,PXTITLE
+3 ;
+4 IF PXFORMAT="L"
Begin DoDot:1
+5 SET PXCNT=PXCNT+1
+6 SET PXRSLT(PXCNT)="VICR"_U_PXIEN_U_$GET(PXICRARR(PXIEN))
+7 IF $GET(PXICRARR(PXIEN,"COMMENTS"))'=""
Begin DoDot:2
+8 SET PXCNT=PXCNT+1
+9 SET PXRSLT(PXCNT)="COM"_U_$GET(PXICRARR(PXIEN,"COMMENTS"))
End DoDot:2
End DoDot:1
+10 ;
+11 IF PXFORMAT="W"
Begin DoDot:1
+12 SET PXNODE=$GET(PXICRARR(PXIEN))
+13 SET PXVIEN=$PIECE($PIECE(PXNODE,U,2),"|",1)
+14 SET PXTITLE=$SELECT($PIECE(PXVIEN,";",2)[920.5:"Patient Refused",1:$GET(PXICRARR(PXIEN,"CONTRAINDICATION/PRECAUTION")))
+15 SET PXTITLE=$SELECT(PXTITLE="C":"Contraindicated",PXTITLE="P":"Precaution",1:PXTITLE)
+16 SET PXX="- "_PXTITLE_": "
+17 SET PXX=PXX_$PIECE($PIECE(PXNODE,U,2),"|",2)
+18 SET PXWARNDT=$PIECE(PXNODE,U,4)
+19 IF PXWARNDT
SET PXX=PXX_" (Until "_$$FMTE^XLFDT(PXWARNDT,1)_")"
+20 SET PXCNT=PXCNT+1
+21 SET PXRSLT(PXCNT)=" "
+22 SET PXCNT=PXCNT+1
+23 SET PXRSLT(PXCNT)=PXX
+24 IF $GET(PXICRARR(PXIEN,"COMMENTS"))'=""
Begin DoDot:2
+25 SET PXX=" Comment: "_PXICRARR(PXIEN,"COMMENTS")
+26 SET PXCNT=PXCNT+1
+27 SET PXRSLT(PXCNT)=PXX
End DoDot:2
End DoDot:1
+28 ;
+29 QUIT
+30 ;
+31 ;
CONDEF(PXRSLT,PXENTRY,PXINST) ;
+1 ;
+2 NEW PXDAYS,PXIEN,PXIEN2,PXPRNT,PXSTA
+3 ;
+4 SET PXRSLT=""
+5 ;
+6 IF '$GET(PXENTRY)!('$GET(PXINST))
QUIT
+7 ; Used to prevent infinite recursion
IF $DATA(PXINST(PXINST))
QUIT
+8 ;
+9 SET PXIEN=$ORDER(^PXV(920.05,"AD",PXINST,PXENTRY,0))
+10 ;
+11 IF PXIEN
Begin DoDot:1
+12 SET PXIEN2=$ORDER(^PXV(920.05,"AD",PXINST,PXENTRY,PXIEN,0))
+13 IF 'PXIEN2
SET PXIEN=""
QUIT
+14 SET PXDAYS=$PIECE($GET(^PXV(920.05,PXIEN,2,PXIEN2,0)),U,2)
+15 IF PXDAYS=""
SET PXIEN=""
QUIT
+16 IF PXDAYS=0
SET PXRSLT="FOREVER"
+17 IF PXDAYS>0
SET PXRSLT=$$FMADD^XLFDT(DT,PXDAYS)
End DoDot:1
+18 ;
+19 ; If site did not create defaults, make recursive
+20 ; call for parent Institution; if parent has defaults,
+21 ; inherit from parent.
+22 IF 'PXIEN
Begin DoDot:1
+23 SET PXSTA=$$STA^XUAF4(PXINST)
+24 IF PXSTA=""
QUIT
+25 SET PXPRNT=$$PRNT^XUAF4(PXSTA)
+26 ;
+27 ; If parent = self, we reached the top of the chain
+28 IF $PIECE(PXPRNT,U,2)=PXSTA
QUIT
+29 IF (+PXPRNT)=PXINST
QUIT
+30 IF 'PXPRNT
QUIT
+31 ;
+32 ; Used to prevent infinite recursion
+33 SET PXINST(PXINST)=""
+34 ;
+35 SET PXINST=+PXPRNT
+36 DO CONDEF(.PXRSLT,PXENTRY,.PXINST)
End DoDot:1
+37 ;
+38 QUIT
+39 ;
+40 ;
