ECMLMF ;ALB/ESD - File Multiple Dates/Multiple Procedures - 29 AUG 97 08:51
;;2.0; EVENT CAPTURE ;**5,10,15,13,17,18,23,42,54,72,76**;8 May 96;Build 6
;
EN ;- Entry point to file selected patients and procedures
;
N DIR,DIRUT,I,J,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
I '$D(^TMP("ECMPIDX",$J))!('$D(^TMP("ECMPTIDX",$J))) W !!,*7,"No patient data found. No patient record(s) have been filed." D MSG G ENQ
;
W !!,"You have selected the following patients for filing:",!
;
;- List patients
S I=0
F S I=$O(^TMP("ECMPTIDX",$J,I)) Q:'I D
. W !?5,I_". ",$P($G(^TMP("ECMPTIDX",$J,I)),"^",3)
W !! S DIR(0)="YA",DIR("A")="Is this correct? ",DIR("B")="YES"
S DIR("?")="Answer YES to continue, NO to exit."
D ^DIR K DIR
I '$G(Y)!($D(DIRUT)) W !,"Exiting option...no patients filed.",! D MSG G ENQ
;
;- Task job
F J="DUZ","ECL","ECDSSU","ECCAT","ECU*" S ZTSAVE(J)=""
S ZTSAVE("^TMP(""ECMPIDX"",$J,")="",ZTSAVE("^TMP(""ECMPTIDX"",$J,")=""
S ZTIO="",ZTDESC="EC MULT DATES/MULT PROCS DATA ENTRY",ZTRTN="GETNODS^ECMLMF",ZTDTH=$H
;
W !!,"These patients will be sent to the background for filing.",!
D ^%ZTLOAD
I $D(ZTSK) W !,"Queued as Task #",ZTSK,!
D MSG
;
ENQ K ^TMP("ECPLST",$J)
Q
;
;
GETNODS ;- Get procedure node and patient node for processing
;
N ECI,ECJ,ECPRNOD,ECPTNOD,ECDXX
S (ECI,ECJ)=0
F S ECI=$O(^TMP("ECMPTIDX",$J,ECI)) Q:'ECI D
. S ECPTNOD="",ECPTNOD=$G(^TMP("ECMPTIDX",$J,ECI))
. K ECDXX M ECDXX=^TMP("ECMPTIDX",$J,ECI,"DXS")
. F S ECJ=$O(^TMP("ECMPIDX",$J,ECJ)) Q:'ECJ D
.. S ECPRNOD="",ECPRNOD=$G(^TMP("ECMPIDX",$J,ECJ))
.. D FILREC
D ENQ^ECMLMD
S ZTREQ="@"
Q
;
;
FILREC ;- Create record in #721 and file fields
;
N DA,ECIEN,ECNOGO,ECPRR,ECPTR,ECREAS,ECSND,DIC,DLAYGO,DIE,DR,I,Y
S ECNOGO=0
S I=$P(^ECH(0),"^",3)
LOCKHD S I=I+1 L +^ECH(I):2 I '$T!$D(^ECH(I)) L -^ECH(I) G LOCKHD
L -^ECH(0)
K DD,DO S X=I,DIC(0)="L",DLAYGO=721,DIC="^ECH(" D FILE^DICN
K DIC,DLAYGO,X
I Y=-1 G FILRECQ
S (ECIEN,DA)=+Y
L +^ECH(ECIEN):2 I '$T G FILRECQ
;
D SETARRY
;
;- File zero node and "P" node
S DIE="^ECH(",DR="[EC CREATE PATIENT ENTRY]" D ^DIE K DR
;
;- File multiple providers, ALB/JAM
S ECFIL=$$FILPRV^ECPRVMUT(ECIEN,.ECU,.ECOUT) K ECFIL
;- File secondary diagnoses codes, ALB/JAM
S (DXS,DXSIEN)=""
F S DXS=$O(ECDXX(DXS)) Q:DXS="" D
. S DXSIEN=+ECDXX(DXS) I DXSIEN<0 Q
. K DIC,DD,DO S DIC(0)="L",DA(1)=ECIEN,DIC("P")=$P(^DD(721,38,0),U,2)
. S X=DXSIEN,DIC="^ECH("_DA(1)_","_"""DX"""_"," D FILE^DICN
K DXS,DXSIEN,DIC
;update encounter's procedures to have same primary & secondary dx
S PXUPD=$$PXUPD^ECUTL2(ECPTR("DFN"),ECPRR("PROCDT"),ECL,ECPTR("CLIN"),ECPTR("DX"),.ECDXX,ECIEN) K PXUPD
;
;File CPT modifiers, ALB/JAM
N MOD,MODIEN
S (ECMODS,MOD)=""
F S MOD=$O(^TMP("ECMPIDX",$J,ECJ,"MOD",MOD)) Q:MOD="" D
. S MODIEN=$P(^TMP("ECMPIDX",$J,ECJ,"MOD",MOD),U,2) I MODIEN<0 Q
. K DIC,DD,DO S DIC(0)="L",DA(1)=ECIEN,DIC("P")=$P(^DD(721,36,0),U,2)
. S X=MODIEN,DIC="^ECH("_DA(1)_","_"""MOD"""_"," D FILE^DICN
. S ECMODS=ECMODS_$S(ECMODS="":"",1:";")_MOD
;
S ECSND=$P($G(^ECD(+$P($G(ECDSSU),"^"),0)),"^",14),DA=ECIEN
I ECSND="" S ECSND="N"
I ECSND="A"!((ECSND="O")&(ECPTR("IO")="O")) D
. S ECNOGO=$$BADFLDS(.ECREAS)
. I ECNOGO S DR="33////^S X=$G(ECREAS)" D ^DIE Q
. I 'ECNOGO D PCE
;
FILRECQ L -^ECH(ECIEN)
Q
;
;
SETARRY ;- Set local arrays with procedure and patient data for filing
;
N I
F I="PROCDT","PROC","REAS","VOL" S ECPRR(I)=$P(ECPRNOD,"^",+$P($T(@I),";;",2))
I ECPRR("REAS")=0 S ECPRR("REAS")=""
S I="PCEPR" S ECPRR(I)=$S($P($G(ECPRR("PROC")),";",2)="ICPT(":$P($G(ECPRR("PROC")),";"),1:$P($G(^EC(725,+$P($G(ECPRR("PROC")),";"),0)),"^",5))
F I="DFN","ORDSEC","IO","CLIN","DX","AO","ENV","IR","SC","ELIG","MST","HNC","CV","SHAD" S ECPTR(I)=$P(ECPTNOD,"^",+$P($T(@I),";;",2))
Q
;
;
BADFLDS(ECRS) ; - Validation checks on fields to be set in "PCE" node
;
S ECRS=""
I ECPTR("CLIN")="" S ECRS="Clinic missing;"
I ECPTR("CLIN")=0 S ECRS="Clinic inactive;"
I ECPTR("DX")="" S ECRS=$G(ECRS)_"Diagnosis missing;"
I ECPRR("PCEPR")="" S ECRS=$G(ECRS)_"CPT code missing;"
Q $S($G(ECRS)="":0,1:1)
;
;
PCE ;- More validation checks on fields to be set in "PCE" node
;
N ECDSS,I,ECAO,ECELIG,ECEV,ECIR,ECSC,ECNP,ECNPP,ECPCENOD,ECMST,ECHNC,ECCV,ECSHAD
G PCEQ:$G(ECPRR("PROCDT"))'["."!('$G(ECPRR("PCEPR")))
F I="DFN","CLIN","DX" G PCEQ:'$G(ECPTR(I))
G PCEQ:'$G(ECPRR("VOL"))
S ECDSS=$P($G(^ECH(ECIEN,0)),"^",20)
G PCEQ:'$G(ECL)!('ECDSS)!('$G(ECU(1)))
;
S ECPTR("AO")=$G(ECPTR("AO"))
S ECAO=$S(ECPTR("AO")="Y":1,ECPTR("AO")="N":0,1:"")
;
S ECPTR("ENV")=$G(ECPTR("ENV"))
S ECEV=$S(ECPTR("ENV")="Y":1,ECPTR("ENV")="N":0,1:"")
;
S ECPTR("IR")=$G(ECPTR("IR"))
S ECIR=$S(ECPTR("IR")="Y":1,ECPTR("IR")="N":0,1:"")
;
S ECPTR("SC")=$G(ECPTR("SC"))
S ECSC=$S(ECPTR("SC")="Y":1,ECPTR("SC")="N":0,1:"")
;
S ECNPP="" I $G(ECPRR("PROC"))["EC" S ECNP=$G(^EC(725,+ECPRR("PROC"),0)),ECNPP=$P(ECNP,"^",2)_" "_$P(ECNP,"^",1)
;
S ECELIG=$S($G(ECPTR("ELIG")):ECPTR("ELIG"),1:"")
;
S ECPTR("MST")=$G(ECPTR("MST"))
S ECMST=$S(ECPTR("MST")="Y":1,ECPTR("MST")="N":0,1:"")
;
;JAM;09/30/02,Head/Neck Cancer
S ECPTR("HNC")=$G(ECPTR("HNC"))
S ECHNC=$S(ECPTR("HNC")="Y":1,ECPTR("HNC")="N":0,1:"")
;
;JAM;10/29/03,Combat Veteran
S ECPTR("CV")=$G(ECPTR("CV"))
S ECCV=$S(ECPTR("CV")="Y":1,ECPTR("CV")="N":0,1:"")
;
;JAM;06/01/05,Project 112/SHAD
S ECPTR("SHAD")=$G(ECPTR("SHAD"))
S ECSHAD=$S(ECPTR("SHAD")="Y":1,ECPTR("SHAD")="N":0,1:"")
;- File "PCE" and "PCE1" nodes
;
S DR="[EC FILE PCE NODE]" D ^DIE K DR
S DR="31////"_$$NOW^XLFDT D ^DIE
PCEQ Q
;
;
MSG ;- Message displayed so error message can be read on screen
;
S DIR(0)="E" D ^DIR
Q
;
;- Subscripts used in creating ECPRR and ECPTR arrays
;
PROCDT ;;2
PROC ;;3
REAS ;;5
VOL ;;7
;
DFN ;;2
ORDSEC ;;4
IO ;;5
CLIN ;;6
DX ;;8
AO ;;10
ENV ;;11
IR ;;12
SC ;;13
ELIG ;;14
MST ;;15
HNC ;;16
CV ;;17
SHAD ;;18
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECMLMF 6056 printed Apr 09, 2024@21:02:25 Page 2
ECMLMF ;ALB/ESD - File Multiple Dates/Multiple Procedures - 29 AUG 97 08:51
+1 ;;2.0; EVENT CAPTURE ;**5,10,15,13,17,18,23,42,54,72,76**;8 May 96;Build 6
+2 ;
EN ;- Entry point to file selected patients and procedures
+1 ;
+2 NEW DIR,DIRUT,I,J,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+3 IF '$DATA(^TMP("ECMPIDX",$JOB))!('$DATA(^TMP("ECMPTIDX",$JOB)))
WRITE !!,*7,"No patient data found. No patient record(s) have been filed."
DO MSG
GOTO ENQ
+4 ;
+5 WRITE !!,"You have selected the following patients for filing:",!
+6 ;
+7 ;- List patients
+8 SET I=0
+9 FOR
SET I=$ORDER(^TMP("ECMPTIDX",$JOB,I))
if 'I
QUIT
Begin DoDot:1
+10 WRITE !?5,I_". ",$PIECE($GET(^TMP("ECMPTIDX",$JOB,I)),"^",3)
End DoDot:1
+11 WRITE !!
SET DIR(0)="YA"
SET DIR("A")="Is this correct? "
SET DIR("B")="YES"
+12 SET DIR("?")="Answer YES to continue, NO to exit."
+13 DO ^DIR
KILL DIR
+14 IF '$GET(Y)!($DATA(DIRUT))
WRITE !,"Exiting option...no patients filed.",!
DO MSG
GOTO ENQ
+15 ;
+16 ;- Task job
+17 FOR J="DUZ","ECL","ECDSSU","ECCAT","ECU*"
SET ZTSAVE(J)=""
+18 SET ZTSAVE("^TMP(""ECMPIDX"",$J,")=""
SET ZTSAVE("^TMP(""ECMPTIDX"",$J,")=""
+19 SET ZTIO=""
SET ZTDESC="EC MULT DATES/MULT PROCS DATA ENTRY"
SET ZTRTN="GETNODS^ECMLMF"
SET ZTDTH=$HOROLOG
+20 ;
+21 WRITE !!,"These patients will be sent to the background for filing.",!
+22 DO ^%ZTLOAD
+23 IF $DATA(ZTSK)
WRITE !,"Queued as Task #",ZTSK,!
+24 DO MSG
+25 ;
ENQ KILL ^TMP("ECPLST",$JOB)
+1 QUIT
+2 ;
+3 ;
GETNODS ;- Get procedure node and patient node for processing
+1 ;
+2 NEW ECI,ECJ,ECPRNOD,ECPTNOD,ECDXX
+3 SET (ECI,ECJ)=0
+4 FOR
SET ECI=$ORDER(^TMP("ECMPTIDX",$JOB,ECI))
if 'ECI
QUIT
Begin DoDot:1
+5 SET ECPTNOD=""
SET ECPTNOD=$GET(^TMP("ECMPTIDX",$JOB,ECI))
+6 KILL ECDXX
MERGE ECDXX=^TMP("ECMPTIDX",$JOB,ECI,"DXS")
+7 FOR
SET ECJ=$ORDER(^TMP("ECMPIDX",$JOB,ECJ))
if 'ECJ
QUIT
Begin DoDot:2
+8 SET ECPRNOD=""
SET ECPRNOD=$GET(^TMP("ECMPIDX",$JOB,ECJ))
+9 DO FILREC
End DoDot:2
End DoDot:1
+10 DO ENQ^ECMLMD
+11 SET ZTREQ="@"
+12 QUIT
+13 ;
+14 ;
FILREC ;- Create record in #721 and file fields
+1 ;
+2 NEW DA,ECIEN,ECNOGO,ECPRR,ECPTR,ECREAS,ECSND,DIC,DLAYGO,DIE,DR,I,Y
+3 SET ECNOGO=0
+4 SET I=$PIECE(^ECH(0),"^",3)
LOCKHD SET I=I+1
LOCK +^ECH(I):2
IF '$TEST!$DATA(^ECH(I))
LOCK -^ECH(I)
GOTO LOCKHD
+1 LOCK -^ECH(0)
+2 KILL DD,DO
SET X=I
SET DIC(0)="L"
SET DLAYGO=721
SET DIC="^ECH("
DO FILE^DICN
+3 KILL DIC,DLAYGO,X
+4 IF Y=-1
GOTO FILRECQ
+5 SET (ECIEN,DA)=+Y
+6 LOCK +^ECH(ECIEN):2
IF '$TEST
GOTO FILRECQ
+7 ;
+8 DO SETARRY
+9 ;
+10 ;- File zero node and "P" node
+11 SET DIE="^ECH("
SET DR="[EC CREATE PATIENT ENTRY]"
DO ^DIE
KILL DR
+12 ;
+13 ;- File multiple providers, ALB/JAM
+14 SET ECFIL=$$FILPRV^ECPRVMUT(ECIEN,.ECU,.ECOUT)
KILL ECFIL
+15 ;- File secondary diagnoses codes, ALB/JAM
+16 SET (DXS,DXSIEN)=""
+17 FOR
SET DXS=$ORDER(ECDXX(DXS))
if DXS=""
QUIT
Begin DoDot:1
+18 SET DXSIEN=+ECDXX(DXS)
IF DXSIEN<0
QUIT
+19 KILL DIC,DD,DO
SET DIC(0)="L"
SET DA(1)=ECIEN
SET DIC("P")=$PIECE(^DD(721,38,0),U,2)
+20 SET X=DXSIEN
SET DIC="^ECH("_DA(1)_","_"""DX"""_","
DO FILE^DICN
End DoDot:1
+21 KILL DXS,DXSIEN,DIC
+22 ;update encounter's procedures to have same primary & secondary dx
+23 SET PXUPD=$$PXUPD^ECUTL2(ECPTR("DFN"),ECPRR("PROCDT"),ECL,ECPTR("CLIN"),ECPTR("DX"),.ECDXX,ECIEN)
KILL PXUPD
+24 ;
+25 ;File CPT modifiers, ALB/JAM
+26 NEW MOD,MODIEN
+27 SET (ECMODS,MOD)=""
+28 FOR
SET MOD=$ORDER(^TMP("ECMPIDX",$JOB,ECJ,"MOD",MOD))
if MOD=""
QUIT
Begin DoDot:1
+29 SET MODIEN=$PIECE(^TMP("ECMPIDX",$JOB,ECJ,"MOD",MOD),U,2)
IF MODIEN<0
QUIT
+30 KILL DIC,DD,DO
SET DIC(0)="L"
SET DA(1)=ECIEN
SET DIC("P")=$PIECE(^DD(721,36,0),U,2)
+31 SET X=MODIEN
SET DIC="^ECH("_DA(1)_","_"""MOD"""_","
DO FILE^DICN
+32 SET ECMODS=ECMODS_$SELECT(ECMODS="":"",1:";")_MOD
End DoDot:1
+33 ;
+34 SET ECSND=$PIECE($GET(^ECD(+$PIECE($GET(ECDSSU),"^"),0)),"^",14)
SET DA=ECIEN
+35 IF ECSND=""
SET ECSND="N"
+36 IF ECSND="A"!((ECSND="O")&(ECPTR("IO")="O"))
Begin DoDot:1
+37 SET ECNOGO=$$BADFLDS(.ECREAS)
+38 IF ECNOGO
SET DR="33////^S X=$G(ECREAS)"
DO ^DIE
QUIT
+39 IF 'ECNOGO
DO PCE
End DoDot:1
+40 ;
FILRECQ LOCK -^ECH(ECIEN)
+1 QUIT
+2 ;
+3 ;
SETARRY ;- Set local arrays with procedure and patient data for filing
+1 ;
+2 NEW I
+3 FOR I="PROCDT","PROC","REAS","VOL"
SET ECPRR(I)=$PIECE(ECPRNOD,"^",+$PIECE($TEXT(@I),";;",2))
+4 IF ECPRR("REAS")=0
SET ECPRR("REAS")=""
+5 SET I="PCEPR"
SET ECPRR(I)=$SELECT($PIECE($GET(ECPRR("PROC")),";",2)="ICPT(":$PIECE($GET(ECPRR("PROC")),";"),1:$PIECE($GET(^EC(725,+$PIECE($GET(ECPRR("PROC")),";"),0)),"^",5))
+6 FOR I="DFN","ORDSEC","IO","CLIN","DX","AO","ENV","IR","SC","ELIG","MST","HNC","CV","SHAD"
SET ECPTR(I)=$PIECE(ECPTNOD,"^",+$PIECE($TEXT(@I),";;",2))
+7 QUIT
+8 ;
+9 ;
BADFLDS(ECRS) ; - Validation checks on fields to be set in "PCE" node
+1 ;
+2 SET ECRS=""
+3 IF ECPTR("CLIN")=""
SET ECRS="Clinic missing;"
+4 IF ECPTR("CLIN")=0
SET ECRS="Clinic inactive;"
+5 IF ECPTR("DX")=""
SET ECRS=$GET(ECRS)_"Diagnosis missing;"
+6 IF ECPRR("PCEPR")=""
SET ECRS=$GET(ECRS)_"CPT code missing;"
+7 QUIT $SELECT($GET(ECRS)="":0,1:1)
+8 ;
+9 ;
PCE ;- More validation checks on fields to be set in "PCE" node
+1 ;
+2 NEW ECDSS,I,ECAO,ECELIG,ECEV,ECIR,ECSC,ECNP,ECNPP,ECPCENOD,ECMST,ECHNC,ECCV,ECSHAD
+3 if $GET(ECPRR("PROCDT"))'["."!('$GET(ECPRR("PCEPR")))
GOTO PCEQ
+4 FOR I="DFN","CLIN","DX"
if '$GET(ECPTR(I))
GOTO PCEQ
+5 if '$GET(ECPRR("VOL"))
GOTO PCEQ
+6 SET ECDSS=$PIECE($GET(^ECH(ECIEN,0)),"^",20)
+7 if '$GET(ECL)!('ECDSS)!('$GET(ECU(1)))
GOTO PCEQ
+8 ;
+9 SET ECPTR("AO")=$GET(ECPTR("AO"))
+10 SET ECAO=$SELECT(ECPTR("AO")="Y":1,ECPTR("AO")="N":0,1:"")
+11 ;
+12 SET ECPTR("ENV")=$GET(ECPTR("ENV"))
+13 SET ECEV=$SELECT(ECPTR("ENV")="Y":1,ECPTR("ENV")="N":0,1:"")
+14 ;
+15 SET ECPTR("IR")=$GET(ECPTR("IR"))
+16 SET ECIR=$SELECT(ECPTR("IR")="Y":1,ECPTR("IR")="N":0,1:"")
+17 ;
+18 SET ECPTR("SC")=$GET(ECPTR("SC"))
+19 SET ECSC=$SELECT(ECPTR("SC")="Y":1,ECPTR("SC")="N":0,1:"")
+20 ;
+21 SET ECNPP=""
IF $GET(ECPRR("PROC"))["EC"
SET ECNP=$GET(^EC(725,+ECPRR("PROC"),0))
SET ECNPP=$PIECE(ECNP,"^",2)_" "_$PIECE(ECNP,"^",1)
+22 ;
+23 SET ECELIG=$SELECT($GET(ECPTR("ELIG")):ECPTR("ELIG"),1:"")
+24 ;
+25 SET ECPTR("MST")=$GET(ECPTR("MST"))
+26 SET ECMST=$SELECT(ECPTR("MST")="Y":1,ECPTR("MST")="N":0,1:"")
+27 ;
+28 ;JAM;09/30/02,Head/Neck Cancer
+29 SET ECPTR("HNC")=$GET(ECPTR("HNC"))
+30 SET ECHNC=$SELECT(ECPTR("HNC")="Y":1,ECPTR("HNC")="N":0,1:"")
+31 ;
+32 ;JAM;10/29/03,Combat Veteran
+33 SET ECPTR("CV")=$GET(ECPTR("CV"))
+34 SET ECCV=$SELECT(ECPTR("CV")="Y":1,ECPTR("CV")="N":0,1:"")
+35 ;
+36 ;JAM;06/01/05,Project 112/SHAD
+37 SET ECPTR("SHAD")=$GET(ECPTR("SHAD"))
+38 SET ECSHAD=$SELECT(ECPTR("SHAD")="Y":1,ECPTR("SHAD")="N":0,1:"")
+39 ;- File "PCE" and "PCE1" nodes
+40 ;
+41 SET DR="[EC FILE PCE NODE]"
DO ^DIE
KILL DR
+42 SET DR="31////"_$$NOW^XLFDT
DO ^DIE
PCEQ QUIT
+1 ;
+2 ;
MSG ;- Message displayed so error message can be read on screen
+1 ;
+2 SET DIR(0)="E"
DO ^DIR
+3 QUIT
+4 ;
+5 ;- Subscripts used in creating ECPRR and ECPTR arrays
+6 ;
PROCDT ;;2
PROC ;;3
REAS ;;5
VOL ;;7
+1 ;
DFN ;;2
ORDSEC ;;4
IO ;;5
CLIN ;;6
DX ;;8
AO ;;10
ENV ;;11
IR ;;12
SC ;;13
ELIG ;;14
MST ;;15
HNC ;;16
CV ;;17
SHAD ;;18
