PXCEICR ;BHM/ADM - EDIT/DISPLAY CONTRAINDICATION/REFUSAL ;05/20/2022
;;1.0;PCE PATIENT CARE ENCOUNTER;**215,217**;Aug 12, 1996;Build 134
;
Q
;
;Line with the line label "FORMAT"
;;Long name~File Number~Node Subscripts~Allow Duplicate entries (1=yes, 0=no)~File global name
; 1 2 3 4 5
;
;Following lines:
;;Node~Piece~,Field Number~Edit Label~Display Label~Display Routine~Edit Routine~Help Text for DIR("?")~Set of PXCEKEYS that can Edit~D if Detail Display Only~
; 1 ~ 2 ~ 3 ~ 4 ~ 5 ~ 6 ~ 7 ~ 8 ~ 9 ~ 10
;The Display & Edit routines are for special cases.
; (The .01 field cannot have a special edit.)
;
FORMAT ;;Imm Contraindication/Refusal Event~9000010.707~0,12,801,811,812~1~^AUPNVICR
;;0~1~.01~Contraindication/Refusal: ~Contra/Refusal Event: ~~~~~B
;;0~4~.04~Immunization: ~Immunization: ~~EIMM^PXCEICR~~~D
;;12~5~1205~Refused all immunizations in this group?: ~Refused all immunizations in this group?: ~~REFGRP^PXCEICR~~~B
;;12~1~1201~Event Date and Time: ~Event Date and Time: ~~~~~D
;;12~4~1204~Encounter Provider: ~Encounter Provider: ~~EPROV12^PXCEPRV~~~D
;;0~5~.05~Warn Until Date: ~Warn Until Date: ~~WARNDT^PXCEICR~~~D
;;0~6~.06~Date/Time Recorded: ~Date/Time Recorded: ~~~~~D
;;811~1~81101~Comments: ~Comments: ~~~~~D
;;
;
;********************************
;Display text for the .01 field
;(Must have is called by ASK^PXCEVFI2 and DEL^PXCEVFI2.)
DISPLY01(PXCEICR,PXCEDT) ;
N DIERR,PXCEDILF,PXCEINT,PXCEEXT
S PXCEINT=$P(PXCEICR,"^",1)
S PXCEEXT=$$EXTERNAL^DILFD(9000010.707,.01,"",PXCEINT,"PXCEDILF")
Q $S('$D(DIERR):PXCEEXT,1:PXCEINT)
;
EIMM ; Edit Immunization
N DA,DIR,DTOUT,DUOUT,X,Y
I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
. N DIERR,PXCEDILF,PXCEINT,PXCEEXT
. S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
. S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
. S DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
S DIR(0)="PA^9999999.14:QEM"
S DIR("S")="I $$IMMCRSEL^PXVUTIL($P($G(PXCEAFTR(0)),U,1),Y)"
S DIR("A")=$P(PXCETEXT,"~",4)
S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
D ^DIR
I X="@" S Y="@"
E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1
S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
Q
;
WARNDT ;
N DA,DIR,DTOUT,DUOUT,X,Y
;
I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
. N DIERR,PXCEDILF,PXCEINT,PXCEEXT
. S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
. S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
. S DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
S DIR(0)=PXCEFILE_","_$P(PXCETEXT,"~",3)_"A"
S DIR("A")=$P(PXCETEXT,"~",4)
I $G(DIR("B"))="",'$G(PXCEFIEN) D
. N PXICR,PXFILE,PXIEN,PXLOC,PXRSLT,PXDEF
. S PXICR=$P($G(PXCEAFTR(0)),U,1)
. S PXFILE=+$P(PXICR,"(",2)
. I 'PXFILE Q
. S PXIEN=+PXICR
. I 'PXIEN Q
. I $G(PXCEVIEN) S PXLOC=$P($G(^AUPNVSIT(PXCEVIEN,0)),U,22)
. D GETICR^PXVRPC5(.PXRSLT,PXFILE,"R:"_PXIEN,"",$G(PXLOC))
. S PXDEF=$P($G(PXRSLT(1)),U,$S(PXFILE=920.5:5,1:8))
. I PXDEF>0 S DIR("B")=$$FMTE^XLFDT(PXDEF)
S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
D ^DIR
I X="@" S Y="@"
E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1
S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
Q
;
REFGRP ; Refused Vaccine Group
N DA,DIR,DTOUT,DUOUT,X,Y
;
I $P($G(PXCEAFTR(0)),U,1)'[920.5 Q
;
I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
. N DIERR,PXCEDILF,PXCEINT,PXCEEXT
. S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
. S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
. S DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
S DIR(0)=PXCEFILE_","_$P(PXCETEXT,"~",3)_"A"
S DIR("A")=$P(PXCETEXT,"~",4)
I $G(DIR("B"))="",'$G(PXCEFIEN) S DIR("B")="YES"
S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
D ^DIR
I X="@" S Y="@"
E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1
S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
Q
;
CONTRA ;
Q:'$G(PXCEPAT)!'+$G(PXD)
N PXCNT,PXD1,PXEXT,PXIEN,PXRESULT,PXVJFLG,PXWUD
S (PXVACK,PXCNT)=0,PXD1=+PXD,PXJUST=""
D PATICR^PXAPIIM(.PXRESULT,PXCEPAT,PXD1)
I '$O(PXRESULT(0)) Q
S PXIEN=0 F S PXIEN=$O(PXRESULT(PXIEN)) Q:'PXIEN D CHK
I PXCNT S PXCONTRA=1 D
. I $P($G(PXCEAFTR("12")),"^",20) D JUST I PXVJFLG S PXVACK=1 Q
. K DIR S DIR("A",1)=""
. S DIR("A")="Acknowledge warning and proceed with administration",DIR(0)="Y",DIR("B")="NO"
. S DIR("?",1)="Enter YES to acknowledge a warning of contraindication/refusal events"
. S DIR("?")="associated with this immunization and to proceed with administration." D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT)!'Y Q
. I Y D JUST I PXVJFLG S PXVACK=1 Q
Q
CHK ;
S PXWUD=$P(PXRESULT(PXIEN),"^",4) I $G(PXWUD),$G(PXWUD)<DT Q
S PXCNT=PXCNT+1 I PXCNT=1 D WARN
S PXEXT=$P($P(PXRESULT(PXIEN),"^",2),"|",2)
I $G(PXWUD) S Y=PXWUD D DD^%DT S PXEXT=PXEXT_" (Until "_Y_")"
D EN^DDIOL(PXEXT,,"!,?4")
N PXC S PXC=$G(PXRESULT(PXIEN,"COMMENTS")) I $L(PXC) S PXC="COMMENT: "_PXC D EN^DDIOL(PXC,,"!,?6")
Q
WARN ;
N PXX S PXX=$C(7)_"WARNING!" D EN^DDIOL(PXX,,"!!")
D EN^DDIOL("Contraindication/refusal event(s) associated with this immunization:",,"!,?2")
Q
JUST ; enter comment concerning override of warning
S PXVJFLG=0
K DIR I $D(PXCEAFTR("16")) S DIR("B")=$P(PXCEAFTR("16"),"^")
S DIR("A")="Warning Override Justification",DIR(0)="9000010.11,1601" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) S:Y="^" PXJUST="@" Q
I Y="" D EN^DDIOL("Override justification entry is required to proceed with administration.",,"!,?2") G JUST
S PXJUST=Y,PXVJFLG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCEICR 5900 printed Dec 13, 2024@02:28:05 Page 2
PXCEICR ;BHM/ADM - EDIT/DISPLAY CONTRAINDICATION/REFUSAL ;05/20/2022
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**215,217**;Aug 12, 1996;Build 134
+2 ;
+3 QUIT
+4 ;
+5 ;Line with the line label "FORMAT"
+6 ;;Long name~File Number~Node Subscripts~Allow Duplicate entries (1=yes, 0=no)~File global name
+7 ; 1 2 3 4 5
+8 ;
+9 ;Following lines:
+10 ;;Node~Piece~,Field Number~Edit Label~Display Label~Display Routine~Edit Routine~Help Text for DIR("?")~Set of PXCEKEYS that can Edit~D if Detail Display Only~
+11 ; 1 ~ 2 ~ 3 ~ 4 ~ 5 ~ 6 ~ 7 ~ 8 ~ 9 ~ 10
+12 ;The Display & Edit routines are for special cases.
+13 ; (The .01 field cannot have a special edit.)
+14 ;
FORMAT ;;Imm Contraindication/Refusal Event~9000010.707~0,12,801,811,812~1~^AUPNVICR
+1 ;;0~1~.01~Contraindication/Refusal: ~Contra/Refusal Event: ~~~~~B
+2 ;;0~4~.04~Immunization: ~Immunization: ~~EIMM^PXCEICR~~~D
+3 ;;12~5~1205~Refused all immunizations in this group?: ~Refused all immunizations in this group?: ~~REFGRP^PXCEICR~~~B
+4 ;;12~1~1201~Event Date and Time: ~Event Date and Time: ~~~~~D
+5 ;;12~4~1204~Encounter Provider: ~Encounter Provider: ~~EPROV12^PXCEPRV~~~D
+6 ;;0~5~.05~Warn Until Date: ~Warn Until Date: ~~WARNDT^PXCEICR~~~D
+7 ;;0~6~.06~Date/Time Recorded: ~Date/Time Recorded: ~~~~~D
+8 ;;811~1~81101~Comments: ~Comments: ~~~~~D
+9 ;;
+10 ;
+11 ;********************************
+12 ;Display text for the .01 field
+13 ;(Must have is called by ASK^PXCEVFI2 and DEL^PXCEVFI2.)
DISPLY01(PXCEICR,PXCEDT) ;
+1 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+2 SET PXCEINT=$PIECE(PXCEICR,"^",1)
+3 SET PXCEEXT=$$EXTERNAL^DILFD(9000010.707,.01,"",PXCEINT,"PXCEDILF")
+4 QUIT $SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
+5 ;
EIMM ; Edit Immunization
+1 NEW DA,DIR,DTOUT,DUOUT,X,Y
+2 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
Begin DoDot:1
+3 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+4 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+5 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+6 SET DIR("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+7 SET DIR(0)="PA^9999999.14:QEM"
+8 SET DIR("S")="I $$IMMCRSEL^PXVUTIL($P($G(PXCEAFTR(0)),U,1),Y)"
+9 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+10 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+11 DO ^DIR
+12 IF X="@"
SET Y="@"
+13 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
+14 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")
+15 QUIT
+16 ;
WARNDT ;
+1 NEW DA,DIR,DTOUT,DUOUT,X,Y
+2 ;
+3 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
Begin DoDot:1
+4 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+5 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+6 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+7 SET DIR("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+8 SET DIR(0)=PXCEFILE_","_$PIECE(PXCETEXT,"~",3)_"A"
+9 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+10 IF $GET(DIR("B"))=""
IF '$GET(PXCEFIEN)
Begin DoDot:1
+11 NEW PXICR,PXFILE,PXIEN,PXLOC,PXRSLT,PXDEF
+12 SET PXICR=$PIECE($GET(PXCEAFTR(0)),U,1)
+13 SET PXFILE=+$PIECE(PXICR,"(",2)
+14 IF 'PXFILE
QUIT
+15 SET PXIEN=+PXICR
+16 IF 'PXIEN
QUIT
+17 IF $GET(PXCEVIEN)
SET PXLOC=$PIECE($GET(^AUPNVSIT(PXCEVIEN,0)),U,22)
+18 DO GETICR^PXVRPC5(.PXRSLT,PXFILE,"R:"_PXIEN,"",$GET(PXLOC))
+19 SET PXDEF=$PIECE($GET(PXRSLT(1)),U,$SELECT(PXFILE=920.5:5,1:8))
+20 IF PXDEF>0
SET DIR("B")=$$FMTE^XLFDT(PXDEF)
End DoDot:1
+21 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+22 DO ^DIR
+23 IF X="@"
SET Y="@"
+24 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
+25 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")
+26 QUIT
+27 ;
REFGRP ; Refused Vaccine Group
+1 NEW DA,DIR,DTOUT,DUOUT,X,Y
+2 ;
+3 IF $PIECE($GET(PXCEAFTR(0)),U,1)'[920.5
QUIT
+4 ;
+5 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
Begin DoDot:1
+6 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+7 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+8 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+9 SET DIR("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+10 SET DIR(0)=PXCEFILE_","_$PIECE(PXCETEXT,"~",3)_"A"
+11 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+12 IF $GET(DIR("B"))=""
IF '$GET(PXCEFIEN)
SET DIR("B")="YES"
+13 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+14 DO ^DIR
+15 IF X="@"
SET Y="@"
+16 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
+17 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")
+18 QUIT
+19 ;
CONTRA ;
+1 if '$GET(PXCEPAT)!'+$GET(PXD)
QUIT
+2 NEW PXCNT,PXD1,PXEXT,PXIEN,PXRESULT,PXVJFLG,PXWUD
+3 SET (PXVACK,PXCNT)=0
SET PXD1=+PXD
SET PXJUST=""
+4 DO PATICR^PXAPIIM(.PXRESULT,PXCEPAT,PXD1)
+5 IF '$ORDER(PXRESULT(0))
QUIT
+6 SET PXIEN=0
FOR
SET PXIEN=$ORDER(PXRESULT(PXIEN))
if 'PXIEN
QUIT
DO CHK
+7 IF PXCNT
SET PXCONTRA=1
Begin DoDot:1
+8 IF $PIECE($GET(PXCEAFTR("12")),"^",20)
DO JUST
IF PXVJFLG
SET PXVACK=1
QUIT
+9 KILL DIR
SET DIR("A",1)=""
+10 SET DIR("A")="Acknowledge warning and proceed with administration"
SET DIR(0)="Y"
SET DIR("B")="NO"
+11 SET DIR("?",1)="Enter YES to acknowledge a warning of contraindication/refusal events"
+12 SET DIR("?")="associated with this immunization and to proceed with administration."
DO ^DIR
KILL DIR
+13 IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+14 IF Y
DO JUST
IF PXVJFLG
SET PXVACK=1
QUIT
End DoDot:1
+15 QUIT
CHK ;
+1 SET PXWUD=$PIECE(PXRESULT(PXIEN),"^",4)
IF $GET(PXWUD)
IF $GET(PXWUD)<DT
QUIT
+2 SET PXCNT=PXCNT+1
IF PXCNT=1
DO WARN
+3 SET PXEXT=$PIECE($PIECE(PXRESULT(PXIEN),"^",2),"|",2)
+4 IF $GET(PXWUD)
SET Y=PXWUD
DO DD^%DT
SET PXEXT=PXEXT_" (Until "_Y_")"
+5 DO EN^DDIOL(PXEXT,,"!,?4")
+6 NEW PXC
SET PXC=$GET(PXRESULT(PXIEN,"COMMENTS"))
IF $LENGTH(PXC)
SET PXC="COMMENT: "_PXC
DO EN^DDIOL(PXC,,"!,?6")
+7 QUIT
WARN ;
+1 NEW PXX
SET PXX=$CHAR(7)_"WARNING!"
DO EN^DDIOL(PXX,,"!!")
+2 DO EN^DDIOL("Contraindication/refusal event(s) associated with this immunization:",,"!,?2")
+3 QUIT
JUST ; enter comment concerning override of warning
+1 SET PXVJFLG=0
+2 KILL DIR
IF $DATA(PXCEAFTR("16"))
SET DIR("B")=$PIECE(PXCEAFTR("16"),"^")
+3 SET DIR("A")="Warning Override Justification"
SET DIR(0)="9000010.11,1601"
DO ^DIR
KILL DIR
+4 IF $DATA(DTOUT)!$DATA(DUOUT)
if Y="^"
SET PXJUST="@"
QUIT
+5 IF Y=""
DO EN^DDIOL("Override justification entry is required to proceed with administration.",,"!,?2")
GOTO JUST
+6 SET PXJUST=Y
SET PXVJFLG=1
+7 QUIT
