Routine: ECMLMF

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)

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="@"

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)

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))

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

 ;- 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  Mar 13, 2025@21:02:23                                                                                                                                                                                                      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

ECMLMF.m