PXCEVFI1 ;ISL/dee,esw - Routine to edit a Visit or V-file entry ;May 14, 2021@11:51:23
;;1.0;PCE PATIENT CARE ENCOUNTER;**23,73,112,136,143,124,184,185,210,215,216,211,217**;Aug 12, 1996;Build 134
Q
;
EDIT ; -- edit the V-File stored in "AFTER"
N DIR,DA,X,Y,C,PT01,PXCEINP,PXCEIN01,PXCEEND,PXD,PXCONTRA,PXJUST,PXVACK
N PXCELINE,PXCETEXT,PXCEDIRB,PXCEMOD,PXVMISS,PXVRT,PXALERGY ; PX*1*216
N PXCEKEY,PXCEIKEY,PXCENKEY,PXMDCNT
W !
G:PXCECAT="VST"!(PXCECAT="APPM")!(PXCECAT="CSTP") REST
;Do not allow editing of V-file .01s; V-file entries must be added
;to or deleted from the encounter. All the other fields can be
;edited. PX*1.0*211
I $G(PXCEAFTR(300))'="" D Q
. N TEXT
. S TEXT(1)="This entry was created as a result of mapping, therefore it cannot be edited."
. D EN^DDIOL(.TEXT)
. H 4
. S PXCELOOP=1
S PT01=$P(PXCEAFTR(0),U,1)
I PT01'="" D G REST
. S PXCETEXT=$P($T(FORMAT+1^@PXCECODE),";;",2)
. W !,$P(PXCETEXT,"~",4),$$EXTERNAL^DILFD(PXCEFILE,.01,"",PT01)
. I PXCECAT="CPT" D
..;Get the number of modifiers.
.. S PXMDCNT=$$CODM^ICPTCOD(PT01,"^TMP(""PXMODARR"",$J",PXCESOR,+^TMP("PXK",$J,"VST",1,0,"AFTER"))
.. K ^TMP("PXMODARR",$J)
;
EDIT01 ;
I (PXCECAT="CPT")!(PXCECAT="POV")!(PXCECAT="SK")!(PXCECAT="IMM") D SC^PXCEVFI2($P(^AUPNVSIT(PXCEVIEN,0),U,5))
S PXCETEXT=$P($T(FORMAT+1^@PXCECODE),";;",2)
K DIR,DA,X,Y,C,PXCEDIRB,TEMP
S PXCEDIRB=""
S TEMP=$P(PXCETEXT,"~",7)
I TEMP'="" D @TEMP
I TEMP="" D
. I PXCEDIRB'="" S DIR("B")=PXCEDIRB
. S DIR(0)=PXCEFILE_",.01OA"
. S DIR("A")=$P(PXCETEXT,"~",4)
. S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
. I PXCECAT="IMM" D
. . S DIR(0)="PAO^9999999.14:QEM"
. . S DIR("S")="I $$IMMSEL^PXVUTIL(Y,$G(PXCEVIEN))"
. D ^DIR
I X="@" D G ENDEDIT
. N DIRUT
. I $P(PXCEAFTR(0),"^",1)="" D
.. W !,"There is no entry to delete."
.. D WAIT^PXCEHELP
. E D DEL^PXCEVFI2(PXCECAT)
I $D(DIRUT),$P(PXCEAFTR(0),"^",1)="" S PXCELOOP=1
I $D(DIRUT) S PXCEQUIT=1 Q
S (PXCEINP,PXD)=Y
S PXCEIN01=X
I $P(Y,"^",2)'=PXCEDIRB,$$DUP(PXCEINP) G EDIT01
I PXCECAT="IMM" D Q:PXCEQUIT ; PX*1*215
. S (PXCONTRA,PXVACK)=0,PXJUST="" D CONTRA^PXCEICR
. I 'PXCONTRA S $P(PXCEAFTR(12),"^",20)="@",$P(PXCEAFTR(16),"^",1)="@" Q
. I PXCONTRA,'PXVACK S PXCEQUIT=1 Q
. I PXCONTRA,PXVACK D
..S $P(PXCEAFTR(12),"^",20)=1
..S $P(PXCEAFTR(16),"^",1)=PXJUST
; for non-historicals stuff info source and require dose, dose unit, route or site ; PX*1*216
I PXCECAT="IMM",'$$HIST,PXCEFIEN="" S $P(PXCEAFTR(13),"^")=$$HL72IEN(920.1,"00"),PXVMISS=0 D REQ I PXVMISS S PXCEQUIT=1 Q ; PX*1*216
; send Adverse Reaction Tracking (ART) alert if allergy type in ^PXV(920.4 is selected ; PX*1*216
I PXCECAT="ICR" I $P($P(PXCEINP,";",2),",")="PXV(920.4" S PXALERGY=($P($P(PXCEINP,";"),",")) I $$ARTAPI^PXVUTIL(PXALERGY) D ARTALERT ; PX*1*216
;--File new CPT code and retrieve IEN
I PXCECAT="CPT" D
. S PXMDCNT=$$CODM^ICPTCOD(+Y,"^TMP(""PXMODARR"",$J",PXCESOR,+^TMP("PXK",$J,"VST",1,0,"AFTER"))
. K ^TMP("PXMODARR",$J)
. I $P(PXCEAFTR(0),"^",1)'=""!(PXMDCNT'>0) Q
. N PXCEFIEN
. D NEWCODE^PXCECPT
. S ^TMP("PXK",$J,PXCECATS,1,"IEN")=PXCEFIEN
I PXCECAT="PRV",$P(PXCEAFTR(0),"^",1)>0,PXCEDIRB]"" S $P(PXCEAFTR(0),"^",6)=""
I $P(PXCEAFTR(0),U,1)="" S $P(PXCEAFTR(0),"^",1)=$P(PXCEINP,"^")
K DIR,DA
;following code added per PX*185
I $D(XQORNOD(0)) I $P(XQORNOD(0),U,4)="HF" D
.N HFIEN,NODE
.S HFIEN=$P(PXCEINP,U),NODE=$G(^AUTTHF(HFIEN,0))
.Q:'$D(NODE)
.I $P(NODE,U,8)'="Y" W !!,"WARNING: This Health Factor is currently not set to",!?10,"display on a Health Summary report.",!!
.K HFIEN,NODE
.Q
;
REST ;Edit the rest of the fields.
N FIELD,SKIPEVDT,TEMP,PXCESKTYP
;Because it has already been prompted for skip Event Date and Time
;for V CPT, V POV, and V Standard Codes.
S SKIPEVDT=$S(PXCECAT="CPT":1,PXCECAT="POV":1,PXCECAT="SC":1,1:0)
S PXCEEND=0
;
; For skin tests, check if entering placement/reading/both
I PXCECAT="SK" D Q:PXCEQUIT
. S PXCESKTYP="B"
. I 'PXCEFIEN S PXCEQUIT=$$NEW^PXCESK(.PXCESKTYP,.PXCEAFTR,PXCEPAT,PXCEVIEN)
. I PXCEFIEN S PXCEQUIT=$$EDIT^PXCESK(.PXCESKTYP,.PXCEAFTR,PXCEFIEN)
. I PXCEQUIT S PXCENOER=1
;
F PXCELINE=2:1 S PXCETEXT=$P($T(FORMAT+PXCELINE^@PXCECODE),";;",2) Q:PXCETEXT']"" D Q:PXCEEND
. S FIELD=$P(PXCETEXT,"~",3)
. I PXCECAT="SK",'$$PROMPT^PXCESK(PXCESKTYP,FIELD) Q
. I (FIELD=1201),SKIPEVDT Q
. I FIELD=.06,PXCECAT="ICR" Q ; PX*1*215
. I FIELD=1301,PXCECAT="IMM",'$$HIST Q ; PX*1*215
. I FIELD=1220,PXCECAT="IMM" Q ; PX*1*215
. I FIELD=1601,PXCECAT="IMM" Q ; PX*1*215
. I FIELD=1214,PXCECAT="SK" Q ; PX*1*210
. I FIELD=1405,PXCECAT="IMM" Q ; PX*1*211
. I FIELD=1406,PXCECAT="IMM" Q ; PX*1*210
. I FIELD=1207,PXCECAT="IMM",$$HIST Q ; PX*1*216
. I (FIELD=1302)!(FIELD=1303)!(FIELD=1312)!(FIELD=1313),PXCECAT="IMM",PXCEFIEN="",'$$HIST Q ; PX*1*216
. I FIELD=1403 D Q:PXCEEND ; PX*1*210
.. I PXCECAT'="IMM" S PXCEEND=1 Q ; PX*1*210
.. N IMMIEN
.. S IMMIEN=$P(PXCEAFTR(0),U,1)
.. I $P($G(^AUTTIMM(IMMIEN,.5)),U,1)'=1 S PXCEEND=1 Q ; PX*1*210
. I $P(PXCETEXT,"~",9)]"",$P(PXCETEXT,"~",3)'=80201 S PXCEKEY="" D Q:PXCEKEY'=1
.. S PXCENKEY=$L($P(PXCETEXT,"~",9))
.. F PXCEIKEY=1:1:PXCENKEY I PXCEKEYS[$E($P(PXCETEXT,"~",9),PXCEIKEY) S PXCEKEY=1 Q
. K DIR,DA,X,Y,C
. S TEMP=$P(PXCETEXT,"~",7)
. I TEMP'="" D @TEMP
. I TEMP="" D
.. I PXCECAT="IMM",FIELD=1303 S PXVRT=$P(PXCEAFTR(13),"^",2) D Q:$$IEN2HL7(920.2,PXVRT)="PO" ; PX*1*216
... I $$IEN2HL7(920.2,PXVRT)="PO",$P(PXCEAFTR(13),"^",3)'="" S $P(PXCEAFTR(13),"^",3)="@"
.. 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 PXCECAT="IMM",$G(DIR("B"))="" D DEF ; PX*1*215
.. S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
.. I PXCECAT="IMM",'$$HIST,$P(PXCETEXT,"~",3)=1303 D SITE Q ; PX*1*216
.. D ^DIR
.. I PXCECAT="IMM",'$$HIST,$$REQF D MUST ; PX*1*216
.. K DIR,DA
.. I X="@" S Y="@"
.. E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1 S:PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST")!(PXCECAT="CPT") PXCEQUIT=1 Q
.. S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
. I ($P(PXCETEXT,"~",3)=1202!($P(PXCETEXT,"~",3)=1204)) D:+Y>0 PROVIDER^PXCEVFI4(+Y)
;
ENDEDIT ;
Q
REQ ; prompt for dose, dose units, route and site for non-historical administrations ; PX*1*216
N PXEXT,PXVF,PXVP
K DIR S PXVP=12,PXVF=1312 D EXTB S DIR("A")="Dose",DIR(0)="9000010.11,1312" D ^DIR,MUST K DIR Q:PXVMISS
S $P(PXCEAFTR(13),"^",12)=$P(Y,"^")
S PXVP=13,PXVF=1313 D EXTB S DIR("A")="Dose Units",DIR(0)="9000010.11,1313" D ^DIR,MUST K DIR Q:PXVMISS
S $P(PXCEAFTR(13),"^",13)=$P(Y,"^")
S PXVP=2,PXVF=1302 D EXTB S DIR("A")="Route of Administration",DIR(0)="9000010.11,1302" D ^DIR,MUST K DIR Q:PXVMISS
S ($P(PXCEAFTR(13),"^",2),PXVRT)=$P(Y,"^")
I $$IEN2HL7(920.2,PXVRT)="PO" Q
SITE S PXVP=3,PXVF=1303 D EXTB
I '$D(^PXV(920.6,PXVRT,0)) S DIR("A")="Site of Administration",DIR(0)="9000010.11,1303" D ^DIR,MUST K DIR Q:PXVMISS S $P(PXCEAFTR(13),"^",3)=$P(Y,"^")
I $D(^PXV(920.6,PXVRT,0)) D D ^DIR,MUST K DIR,DA Q:PXVMISS S $P(PXCEAFTR(13),"^",3)=$P(Y,"^",2)
.S DA(1)=PXVRT,DIR("A")="Site of Administration",DIR(0)="P^PXV(920.6,"_PXVRT_",1,:QEMZ"
.S DIR("?")="Select the site the vaccine was administered."
Q
REQF() ; check if field is dose, dose unit, route or site ; PX*1*216
N PXV294,PXVF
S PXV294=0,PXVF=$P(PXCETEXT,"~",3)
I PXVF=1312!(PXVF=1313)!(PXVF=1302)!(PXVF=1303) S PXV294=1
Q PXV294
;
MUST ; prompt for required entries if not entered ; PX*1*216
S PXVMISS=0
I X="@"!((Y="")) N PXVX S PXVX=$C(7)_"This is a required response. Enter '^' to exit." D EN^DDIOL(PXVX) D ^DIR
I $D(DTOUT)!$D(DUOUT) S PXVMISS=1 Q
I X="@"!((Y="")) D MUST
Q
EXTB ; get external value for DIR("B") ; PX*1*216
N PXVDEF,PXVFAC,PXVIMM
Q:'$D(PXCEVIEN)
S PXVFAC=$$INST^PXVRESP(PXCEVIEN) Q:'PXVFAC
S PXVIMM=+$G(PXD) Q:'PXVIMM
S PXVDEF=$P($G(^PXV(920.05,PXVFAC,1,PXVIMM,13)),"^",PXVP)
S PXEXT=$$EXTERNAL^DILFD(PXCEFILE,PXVF,"",PXVDEF,"PXCEDILF")
I PXEXT'="" S DIR("B")=PXEXT
Q
DUP(PXCEINP) ; -- Check for dup entries.
Q:PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST") 0
;
N PXCEDUP,PXCEINDX,X,Y
S PXCEDUP=0
S PXCEINDX=""
F S PXCEINDX=$O(@(PXCEAUPN_"(""AD"",PXCEVIEN,PXCEINDX)")) Q:'PXCEINDX!PXCEDUP S:+@(PXCEAUPN_"(PXCEINDX,0)")=+PXCEINP&(PXCEINDX'=PXCEFIEN) PXCEDUP=1
I PXCEDUP D
. I PXCEDUP
. W !,$P(PXCEINP,"^",2)," is already a "_PXCECATT_" for this Encounter."
. I PXCECAT="POV" W !!,"Duplicate Diagnosis Not Allowed." Q ;PX/112
. I PXCECAT="CPT",$$GET1^DIQ(357.69,$P(PXCEINP,"^",2),.01)>0 D Q
. . W !,"No duplicate E&M codes allowed." ;PX/136
. I $P($T(FORMAT^@PXCECODE),"~",4) D
.. N DIR,DA
.. S DIR(0)="Y"
.. S DIR("A")="Do you want to add another "_$P(PXCEINP,"^",2)_""
.. S DIR("B")="NO"
.. D ^DIR
.. S PXCEDUP='+Y
Q PXCEDUP
;
DEF ; get default response from file #920.05; PX*1*215
N PXVDEF,PXVFAC,PXVIMM,PXCEEXT
Q:'$D(PXCEVIEN)
S PXVFAC=$$INST^PXVRESP(PXCEVIEN) Q:'PXVFAC
S PXVIMM=+$G(PXD) Q:'PXVIMM
S PXVDEF=$P($G(^PXV(920.05,PXVFAC,1,PXVIMM,$P(PXCETEXT,"~",1))),"^",$P(PXCETEXT,"~",2))
S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXVDEF,"PXCEDILF")
I PXCEEXT'="" S DIR("B")=PXCEEXT
Q
HIST() ; check if historical encounter; PX*1*215
N PXVHIST S PXVHIST=0
I $G(PXCEVIEN),$P(^AUPNVSIT(PXCEVIEN,0),"^",7)="E" S PXVHIST=1
Q PXVHIST
ARTALERT ; Alert for Adverse Reaction Tracking (ART) ; PX*1*216
Q:('$D(PXCEPAT("NAME")))!('$D(PXCEPAT("SSN_BRIEF"))) ; PX*1*216
N XQA,XQAID,XQADATA,XQAMSG,XQATEXT,PXVVAR ; PX*1*216
S XQA(DUZ)="" ; PX*1*216
S XQAID="PX VIMM" ; PX*1*216
S XQADATA=$E(PXCEPAT("NAME"),1,9)_" ("_$E(PXCEPAT("NAME"))_PXCEPAT("SSN_BRIEF")_"): " ; PX*1*216/p217
S XQAMSG=XQADATA_"Allergy should be recorded in Adverse Reaction Tracking." ; PX*1*216/p217
S XQATEXT(1)="" ; PX*1*216
S XQATEXT(2)="You have recorded an allergy/adverse reaction contraindication reason. This" ; PX*1*216
S XQATEXT(3)="information should also be recorded in the Adverse Reaction Tracking package" ; PX*1*216
S XQATEXT(4)="if it is not already present there." ; PX*1*216
S PXVVAR=$$SETUP1^XQALERT ; PX*1*216
Q ; PX*1*216
;
HL72IEN(PXFILE,PXHL7CODE) ;
I $G(PXFILE)'?1(1"920.1",1"920.2") Q ""
I '$D(PXHL7CODE) Q ""
Q $O(^PXV(PXFILE,"H",PXHL7CODE,0))
;
IEN2HL7(PXFILE,PXIEN) ;
I $G(PXFILE)'?1(1"920.1",1"920.2",1"920.3",1"920.5") Q ""
I '$G(PXIEN) Q ""
Q $P($G(^PXV(PXFILE,PXIEN,0)),U,2)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCEVFI1 10864 printed Apr 09, 2024@21:33:33 Page 2
PXCEVFI1 ;ISL/dee,esw - Routine to edit a Visit or V-file entry ;May 14, 2021@11:51:23
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**23,73,112,136,143,124,184,185,210,215,216,211,217**;Aug 12, 1996;Build 134
+2 QUIT
+3 ;
EDIT ; -- edit the V-File stored in "AFTER"
+1 NEW DIR,DA,X,Y,C,PT01,PXCEINP,PXCEIN01,PXCEEND,PXD,PXCONTRA,PXJUST,PXVACK
+2 ; PX*1*216
NEW PXCELINE,PXCETEXT,PXCEDIRB,PXCEMOD,PXVMISS,PXVRT,PXALERGY
+3 NEW PXCEKEY,PXCEIKEY,PXCENKEY,PXMDCNT
+4 WRITE !
+5 if PXCECAT="VST"!(PXCECAT="APPM")!(PXCECAT="CSTP")
GOTO REST
+6 ;Do not allow editing of V-file .01s; V-file entries must be added
+7 ;to or deleted from the encounter. All the other fields can be
+8 ;edited. PX*1.0*211
+9 IF $GET(PXCEAFTR(300))'=""
Begin DoDot:1
+10 NEW TEXT
+11 SET TEXT(1)="This entry was created as a result of mapping, therefore it cannot be edited."
+12 DO EN^DDIOL(.TEXT)
+13 HANG 4
+14 SET PXCELOOP=1
End DoDot:1
QUIT
+15 SET PT01=$PIECE(PXCEAFTR(0),U,1)
+16 IF PT01'=""
Begin DoDot:1
+17 SET PXCETEXT=$PIECE($TEXT(FORMAT+1^@PXCECODE),";;",2)
+18 WRITE !,$PIECE(PXCETEXT,"~",4),$$EXTERNAL^DILFD(PXCEFILE,.01,"",PT01)
+19 IF PXCECAT="CPT"
Begin DoDot:2
+20 ;Get the number of modifiers.
+21 SET PXMDCNT=$$CODM^ICPTCOD(PT01,"^TMP(""PXMODARR"",$J",PXCESOR,+^TMP("PXK",$JOB,"VST",1,0,"AFTER"))
+22 KILL ^TMP("PXMODARR",$JOB)
End DoDot:2
End DoDot:1
GOTO REST
+23 ;
EDIT01 ;
+1 IF (PXCECAT="CPT")!(PXCECAT="POV")!(PXCECAT="SK")!(PXCECAT="IMM")
DO SC^PXCEVFI2($PIECE(^AUPNVSIT(PXCEVIEN,0),U,5))
+2 SET PXCETEXT=$PIECE($TEXT(FORMAT+1^@PXCECODE),";;",2)
+3 KILL DIR,DA,X,Y,C,PXCEDIRB,TEMP
+4 SET PXCEDIRB=""
+5 SET TEMP=$PIECE(PXCETEXT,"~",7)
+6 IF TEMP'=""
DO @TEMP
+7 IF TEMP=""
Begin DoDot:1
+8 IF PXCEDIRB'=""
SET DIR("B")=PXCEDIRB
+9 SET DIR(0)=PXCEFILE_",.01OA"
+10 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+11 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+12 IF PXCECAT="IMM"
Begin DoDot:2
+13 SET DIR(0)="PAO^9999999.14:QEM"
+14 SET DIR("S")="I $$IMMSEL^PXVUTIL(Y,$G(PXCEVIEN))"
End DoDot:2
+15 DO ^DIR
End DoDot:1
+16 IF X="@"
Begin DoDot:1
+17 NEW DIRUT
+18 IF $PIECE(PXCEAFTR(0),"^",1)=""
Begin DoDot:2
+19 WRITE !,"There is no entry to delete."
+20 DO WAIT^PXCEHELP
End DoDot:2
+21 IF '$TEST
DO DEL^PXCEVFI2(PXCECAT)
End DoDot:1
GOTO ENDEDIT
+22 IF $DATA(DIRUT)
IF $PIECE(PXCEAFTR(0),"^",1)=""
SET PXCELOOP=1
+23 IF $DATA(DIRUT)
SET PXCEQUIT=1
QUIT
+24 SET (PXCEINP,PXD)=Y
+25 SET PXCEIN01=X
+26 IF $PIECE(Y,"^",2)'=PXCEDIRB
IF $$DUP(PXCEINP)
GOTO EDIT01
+27 ; PX*1*215
IF PXCECAT="IMM"
Begin DoDot:1
+28 SET (PXCONTRA,PXVACK)=0
SET PXJUST=""
DO CONTRA^PXCEICR
+29 IF 'PXCONTRA
SET $PIECE(PXCEAFTR(12),"^",20)="@"
SET $PIECE(PXCEAFTR(16),"^",1)="@"
QUIT
+30 IF PXCONTRA
IF 'PXVACK
SET PXCEQUIT=1
QUIT
+31 IF PXCONTRA
IF PXVACK
Begin DoDot:2
+32 SET $PIECE(PXCEAFTR(12),"^",20)=1
+33 SET $PIECE(PXCEAFTR(16),"^",1)=PXJUST
End DoDot:2
End DoDot:1
if PXCEQUIT
QUIT
+34 ; for non-historicals stuff info source and require dose, dose unit, route or site ; PX*1*216
+35 ; PX*1*216
IF PXCECAT="IMM"
IF '$$HIST
IF PXCEFIEN=""
SET $PIECE(PXCEAFTR(13),"^")=$$HL72IEN(920.1,"00")
SET PXVMISS=0
DO REQ
IF PXVMISS
SET PXCEQUIT=1
QUIT
+36 ; send Adverse Reaction Tracking (ART) alert if allergy type in ^PXV(920.4 is selected ; PX*1*216
+37 ; PX*1*216
IF PXCECAT="ICR"
IF $PIECE($PIECE(PXCEINP,";",2),",")="PXV(920.4"
SET PXALERGY=($PIECE($PIECE(PXCEINP,";"),","))
IF $$ARTAPI^PXVUTIL(PXALERGY)
DO ARTALERT
+38 ;--File new CPT code and retrieve IEN
+39 IF PXCECAT="CPT"
Begin DoDot:1
+40 SET PXMDCNT=$$CODM^ICPTCOD(+Y,"^TMP(""PXMODARR"",$J",PXCESOR,+^TMP("PXK",$JOB,"VST",1,0,"AFTER"))
+41 KILL ^TMP("PXMODARR",$JOB)
+42 IF $PIECE(PXCEAFTR(0),"^",1)'=""!(PXMDCNT'>0)
QUIT
+43 NEW PXCEFIEN
+44 DO NEWCODE^PXCECPT
+45 SET ^TMP("PXK",$JOB,PXCECATS,1,"IEN")=PXCEFIEN
End DoDot:1
+46 IF PXCECAT="PRV"
IF $PIECE(PXCEAFTR(0),"^",1)>0
IF PXCEDIRB]""
SET $PIECE(PXCEAFTR(0),"^",6)=""
+47 IF $PIECE(PXCEAFTR(0),U,1)=""
SET $PIECE(PXCEAFTR(0),"^",1)=$PIECE(PXCEINP,"^")
+48 KILL DIR,DA
+49 ;following code added per PX*185
+50 IF $DATA(XQORNOD(0))
IF $PIECE(XQORNOD(0),U,4)="HF"
Begin DoDot:1
+51 NEW HFIEN,NODE
+52 SET HFIEN=$PIECE(PXCEINP,U)
SET NODE=$GET(^AUTTHF(HFIEN,0))
+53 if '$DATA(NODE)
QUIT
+54 IF $PIECE(NODE,U,8)'="Y"
WRITE !!,"WARNING: This Health Factor is currently not set to",!?10,"display on a Health Summary report.",!!
+55 KILL HFIEN,NODE
+56 QUIT
End DoDot:1
+57 ;
REST ;Edit the rest of the fields.
+1 NEW FIELD,SKIPEVDT,TEMP,PXCESKTYP
+2 ;Because it has already been prompted for skip Event Date and Time
+3 ;for V CPT, V POV, and V Standard Codes.
+4 SET SKIPEVDT=$SELECT(PXCECAT="CPT":1,PXCECAT="POV":1,PXCECAT="SC":1,1:0)
+5 SET PXCEEND=0
+6 ;
+7 ; For skin tests, check if entering placement/reading/both
+8 IF PXCECAT="SK"
Begin DoDot:1
+9 SET PXCESKTYP="B"
+10 IF 'PXCEFIEN
SET PXCEQUIT=$$NEW^PXCESK(.PXCESKTYP,.PXCEAFTR,PXCEPAT,PXCEVIEN)
+11 IF PXCEFIEN
SET PXCEQUIT=$$EDIT^PXCESK(.PXCESKTYP,.PXCEAFTR,PXCEFIEN)
+12 IF PXCEQUIT
SET PXCENOER=1
End DoDot:1
if PXCEQUIT
QUIT
+13 ;
+14 FOR PXCELINE=2:1
SET PXCETEXT=$PIECE($TEXT(FORMAT+PXCELINE^@PXCECODE),";;",2)
if PXCETEXT']""
QUIT
Begin DoDot:1
+15 SET FIELD=$PIECE(PXCETEXT,"~",3)
+16 IF PXCECAT="SK"
IF '$$PROMPT^PXCESK(PXCESKTYP,FIELD)
QUIT
+17 IF (FIELD=1201)
IF SKIPEVDT
QUIT
+18 ; PX*1*215
IF FIELD=.06
IF PXCECAT="ICR"
QUIT
+19 ; PX*1*215
IF FIELD=1301
IF PXCECAT="IMM"
IF '$$HIST
QUIT
+20 ; PX*1*215
IF FIELD=1220
IF PXCECAT="IMM"
QUIT
+21 ; PX*1*215
IF FIELD=1601
IF PXCECAT="IMM"
QUIT
+22 ; PX*1*210
IF FIELD=1214
IF PXCECAT="SK"
QUIT
+23 ; PX*1*211
IF FIELD=1405
IF PXCECAT="IMM"
QUIT
+24 ; PX*1*210
IF FIELD=1406
IF PXCECAT="IMM"
QUIT
+25 ; PX*1*216
IF FIELD=1207
IF PXCECAT="IMM"
IF $$HIST
QUIT
+26 ; PX*1*216
IF (FIELD=1302)!(FIELD=1303)!(FIELD=1312)!(FIELD=1313)
IF PXCECAT="IMM"
IF PXCEFIEN=""
IF '$$HIST
QUIT
+27 ; PX*1*210
IF FIELD=1403
Begin DoDot:2
+28 ; PX*1*210
IF PXCECAT'="IMM"
SET PXCEEND=1
QUIT
+29 NEW IMMIEN
+30 SET IMMIEN=$PIECE(PXCEAFTR(0),U,1)
+31 ; PX*1*210
IF $PIECE($GET(^AUTTIMM(IMMIEN,.5)),U,1)'=1
SET PXCEEND=1
QUIT
End DoDot:2
if PXCEEND
QUIT
+32 IF $PIECE(PXCETEXT,"~",9)]""
IF $PIECE(PXCETEXT,"~",3)'=80201
SET PXCEKEY=""
Begin DoDot:2
+33 SET PXCENKEY=$LENGTH($PIECE(PXCETEXT,"~",9))
+34 FOR PXCEIKEY=1:1:PXCENKEY
IF PXCEKEYS[$EXTRACT($PIECE(PXCETEXT,"~",9),PXCEIKEY)
SET PXCEKEY=1
QUIT
End DoDot:2
if PXCEKEY'=1
QUIT
+35 KILL DIR,DA,X,Y,C
+36 SET TEMP=$PIECE(PXCETEXT,"~",7)
+37 IF TEMP'=""
DO @TEMP
+38 IF TEMP=""
Begin DoDot:2
+39 ; PX*1*216
IF PXCECAT="IMM"
IF FIELD=1303
SET PXVRT=$PIECE(PXCEAFTR(13),"^",2)
Begin DoDot:3
+40 IF $$IEN2HL7(920.2,PXVRT)="PO"
IF $PIECE(PXCEAFTR(13),"^",3)'=""
SET $PIECE(PXCEAFTR(13),"^",3)="@"
End DoDot:3
if $$IEN2HL7(920.2,PXVRT)="PO"
QUIT
+41 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
Begin DoDot:3
+42 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+43 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+44 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+45 SET DIR("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:3
+46 SET DIR(0)=PXCEFILE_","_$PIECE(PXCETEXT,"~",3)_"A"
+47 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+48 ; PX*1*215
IF PXCECAT="IMM"
IF $GET(DIR("B"))=""
DO DEF
+49 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+50 ; PX*1*216
IF PXCECAT="IMM"
IF '$$HIST
IF $PIECE(PXCETEXT,"~",3)=1303
DO SITE
QUIT
+51 DO ^DIR
+52 ; PX*1*216
IF PXCECAT="IMM"
IF '$$HIST
IF $$REQF
DO MUST
+53 KILL DIR,DA
+54 IF X="@"
SET Y="@"
+55 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
if PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST")!(PXCECAT="CPT")
SET PXCEQUIT=1
QUIT
+56 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")
End DoDot:2
+57 IF ($PIECE(PXCETEXT,"~",3)=1202!($PIECE(PXCETEXT,"~",3)=1204))
if +Y>0
DO PROVIDER^PXCEVFI4(+Y)
End DoDot:1
if PXCEEND
QUIT
+58 ;
ENDEDIT ;
+1 QUIT
REQ ; prompt for dose, dose units, route and site for non-historical administrations ; PX*1*216
+1 NEW PXEXT,PXVF,PXVP
+2 KILL DIR
SET PXVP=12
SET PXVF=1312
DO EXTB
SET DIR("A")="Dose"
SET DIR(0)="9000010.11,1312"
DO ^DIR
DO MUST
KILL DIR
if PXVMISS
QUIT
+3 SET $PIECE(PXCEAFTR(13),"^",12)=$PIECE(Y,"^")
+4 SET PXVP=13
SET PXVF=1313
DO EXTB
SET DIR("A")="Dose Units"
SET DIR(0)="9000010.11,1313"
DO ^DIR
DO MUST
KILL DIR
if PXVMISS
QUIT
+5 SET $PIECE(PXCEAFTR(13),"^",13)=$PIECE(Y,"^")
+6 SET PXVP=2
SET PXVF=1302
DO EXTB
SET DIR("A")="Route of Administration"
SET DIR(0)="9000010.11,1302"
DO ^DIR
DO MUST
KILL DIR
if PXVMISS
QUIT
+7 SET ($PIECE(PXCEAFTR(13),"^",2),PXVRT)=$PIECE(Y,"^")
+8 IF $$IEN2HL7(920.2,PXVRT)="PO"
QUIT
SITE SET PXVP=3
SET PXVF=1303
DO EXTB
+1 IF '$DATA(^PXV(920.6,PXVRT,0))
SET DIR("A")="Site of Administration"
SET DIR(0)="9000010.11,1303"
DO ^DIR
DO MUST
KILL DIR
if PXVMISS
QUIT
SET $PIECE(PXCEAFTR(13),"^",3)=$PIECE(Y,"^")
+2 IF $DATA(^PXV(920.6,PXVRT,0))
Begin DoDot:1
+3 SET DA(1)=PXVRT
SET DIR("A")="Site of Administration"
SET DIR(0)="P^PXV(920.6,"_PXVRT_",1,:QEMZ"
+4 SET DIR("?")="Select the site the vaccine was administered."
End DoDot:1
DO ^DIR
DO MUST
KILL DIR,DA
if PXVMISS
QUIT
SET $PIECE(PXCEAFTR(13),"^",3)=$PIECE(Y,"^",2)
+5 QUIT
REQF() ; check if field is dose, dose unit, route or site ; PX*1*216
+1 NEW PXV294,PXVF
+2 SET PXV294=0
SET PXVF=$PIECE(PXCETEXT,"~",3)
+3 IF PXVF=1312!(PXVF=1313)!(PXVF=1302)!(PXVF=1303)
SET PXV294=1
+4 QUIT PXV294
+5 ;
MUST ; prompt for required entries if not entered ; PX*1*216
+1 SET PXVMISS=0
+2 IF X="@"!((Y=""))
NEW PXVX
SET PXVX=$CHAR(7)_"This is a required response. Enter '^' to exit."
DO EN^DDIOL(PXVX)
DO ^DIR
+3 IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXVMISS=1
QUIT
+4 IF X="@"!((Y=""))
DO MUST
+5 QUIT
EXTB ; get external value for DIR("B") ; PX*1*216
+1 NEW PXVDEF,PXVFAC,PXVIMM
+2 if '$DATA(PXCEVIEN)
QUIT
+3 SET PXVFAC=$$INST^PXVRESP(PXCEVIEN)
if 'PXVFAC
QUIT
+4 SET PXVIMM=+$GET(PXD)
if 'PXVIMM
QUIT
+5 SET PXVDEF=$PIECE($GET(^PXV(920.05,PXVFAC,1,PXVIMM,13)),"^",PXVP)
+6 SET PXEXT=$$EXTERNAL^DILFD(PXCEFILE,PXVF,"",PXVDEF,"PXCEDILF")
+7 IF PXEXT'=""
SET DIR("B")=PXEXT
+8 QUIT
DUP(PXCEINP) ; -- Check for dup entries.
+1 if PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST")
QUIT 0
+2 ;
+3 NEW PXCEDUP,PXCEINDX,X,Y
+4 SET PXCEDUP=0
+5 SET PXCEINDX=""
+6 FOR
SET PXCEINDX=$ORDER(@(PXCEAUPN_"(""AD"",PXCEVIEN,PXCEINDX)"))
if 'PXCEINDX!PXCEDUP
QUIT
if +@(PXCEAUPN_"(PXCEINDX,0)")=+PXCEINP&(PXCEINDX'=PXCEFIEN)
SET PXCEDUP=1
+7 IF PXCEDUP
Begin DoDot:1
+8 IF PXCEDUP
+9 WRITE !,$PIECE(PXCEINP,"^",2)," is already a "_PXCECATT_" for this Encounter."
+10 ;PX/112
IF PXCECAT="POV"
WRITE !!,"Duplicate Diagnosis Not Allowed."
QUIT
+11 IF PXCECAT="CPT"
IF $$GET1^DIQ(357.69,$PIECE(PXCEINP,"^",2),.01)>0
Begin DoDot:2
+12 ;PX/136
WRITE !,"No duplicate E&M codes allowed."
End DoDot:2
QUIT
+13 IF $PIECE($TEXT(FORMAT^@PXCECODE),"~",4)
Begin DoDot:2
+14 NEW DIR,DA
+15 SET DIR(0)="Y"
+16 SET DIR("A")="Do you want to add another "_$PIECE(PXCEINP,"^",2)_""
+17 SET DIR("B")="NO"
+18 DO ^DIR
+19 SET PXCEDUP='+Y
End DoDot:2
End DoDot:1
+20 QUIT PXCEDUP
+21 ;
DEF ; get default response from file #920.05; PX*1*215
+1 NEW PXVDEF,PXVFAC,PXVIMM,PXCEEXT
+2 if '$DATA(PXCEVIEN)
QUIT
+3 SET PXVFAC=$$INST^PXVRESP(PXCEVIEN)
if 'PXVFAC
QUIT
+4 SET PXVIMM=+$GET(PXD)
if 'PXVIMM
QUIT
+5 SET PXVDEF=$PIECE($GET(^PXV(920.05,PXVFAC,1,PXVIMM,$PIECE(PXCETEXT,"~",1))),"^",$PIECE(PXCETEXT,"~",2))
+6 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXVDEF,"PXCEDILF")
+7 IF PXCEEXT'=""
SET DIR("B")=PXCEEXT
+8 QUIT
HIST() ; check if historical encounter; PX*1*215
+1 NEW PXVHIST
SET PXVHIST=0
+2 IF $GET(PXCEVIEN)
IF $PIECE(^AUPNVSIT(PXCEVIEN,0),"^",7)="E"
SET PXVHIST=1
+3 QUIT PXVHIST
ARTALERT ; Alert for Adverse Reaction Tracking (ART) ; PX*1*216
+1 ; PX*1*216
if ('$DATA(PXCEPAT("NAME")))!('$DATA(PXCEPAT("SSN_BRIEF")))
QUIT
+2 ; PX*1*216
NEW XQA,XQAID,XQADATA,XQAMSG,XQATEXT,PXVVAR
+3 ; PX*1*216
SET XQA(DUZ)=""
+4 ; PX*1*216
SET XQAID="PX VIMM"
+5 ; PX*1*216/p217
SET XQADATA=$EXTRACT(PXCEPAT("NAME"),1,9)_" ("_$EXTRACT(PXCEPAT("NAME"))_PXCEPAT("SSN_BRIEF")_"): "
+6 ; PX*1*216/p217
SET XQAMSG=XQADATA_"Allergy should be recorded in Adverse Reaction Tracking."
+7 ; PX*1*216
SET XQATEXT(1)=""
+8 ; PX*1*216
SET XQATEXT(2)="You have recorded an allergy/adverse reaction contraindication reason. This"
+9 ; PX*1*216
SET XQATEXT(3)="information should also be recorded in the Adverse Reaction Tracking package"
+10 ; PX*1*216
SET XQATEXT(4)="if it is not already present there."
+11 ; PX*1*216
SET PXVVAR=$$SETUP1^XQALERT
+12 ; PX*1*216
QUIT
+13 ;
HL72IEN(PXFILE,PXHL7CODE) ;
+1 IF $GET(PXFILE)'?1(1"920.1",1"920.2")
QUIT ""
+2 IF '$DATA(PXHL7CODE)
QUIT ""
+3 QUIT $ORDER(^PXV(PXFILE,"H",PXHL7CODE,0))
+4 ;
IEN2HL7(PXFILE,PXIEN) ;
+1 IF $GET(PXFILE)'?1(1"920.1",1"920.2",1"920.3",1"920.5")
QUIT ""
+2 IF '$GET(PXIEN)
QUIT ""
+3 QUIT $PIECE($GET(^PXV(PXFILE,PXIEN,0)),U,2)
+4 ;
