- 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 Jan 18, 2025@03:29:06 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