ECNTPCE ;ALB/JAM-Event Capture Records failing transmission to PCE;Sep 24, 2020@14:55:55
 ;;2.0;EVENT CAPTURE;**61,72,119,152**;8 May 96;Build 19
EN ; entry point
 K %DT S %DT="AEX",%DT("A")="Start with Date:  " D ^%DT I Y<0 G END
 S ECSD=Y,%DT("A")="End with Date:  " D ^%DT G:Y<0 END S ECED=Y
 I ECED<ECSD W !,"End date must be after start date",! G EN
 S ECDATE=$$FMTE^XLFDT(ECSD)_U_$$FMTE^XLFDT(ECED)
 S ECSD=ECSD-.0001,ECED=ECED+.9999
 K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Select Device: ",%ZIS="QM"
 D ^%ZIS G:POP END
 I $D(IO("Q")) K IO("Q") D  G END
 .S (ZTSAVE("ECDFN"),ZTSAVE("ECDATE"),ZTSAVE("ECED"),ZTSAVE("ECSD"))=""
 .S ZTDESC="ECS RECORDS FAILING TRANSMISSION TO PCE REPORT",ZTRTN="START^ECNTPCE"
 .S ZTIO=ION D ^%ZTLOAD,HOME^%ZIS
 W !,?5,"Please be patient, this may take a few moments..."
 ;
START ; entry when queued
 N ECOUT,X,Y,DIR,LINE,ECPG,ECRDT,%H,CNT ;119
 S ECOUT=0,ECPG=1
 S %H=$H D YX^%DTC S ECRDT=Y
 U IO
 I $G(ECPTYP)="E" S CNT=1,^TMP($J,"ECRPT",CNT)="DATE/TIME^LOCATION^DSS UNIT^CATEGORY^PATIENT^SSN^PROCEDURE CODE^PROCEDURE NAME^PROV 1^PROV 2^PROV 3^PROV 4^PROV 5^PROV 6^PROV 7^REASON 1^REASON 2^REASON 3" ;119
 I $G(ECPTYP)="E" D GET,^ECKILL Q  ;119 get data to export and stop processing.
 D GET
 D END
 Q
GET ; start processing or records
 N DATE,ECL,ECNT,ECFN,ECEC,ECPX,ECSTR,ECD
 N NLOC,NDSSUNT,JJ ;152
 K ^TMP("ECNTPCE",$J)
 ;***152 Begins
 ;Set locations and  dss units into ien subscripted arrays
 S JJ="" F  S JJ=$O(ECLOC(JJ)) Q:JJ=""  D
 .S NLOC($P(ECLOC(JJ),U,1))=$P(ECLOC(JJ),U,2)
 S JJ="" F  S JJ=$O(ECDSSU(JJ)) Q:JJ=""  D
 .S NDSSUNT($P(ECDSSU(JJ),U,1))=$P(ECDSSU(JJ),U,2)
 ;***152 Ends
 S DATE=ECSD,ECNT=0
 F  S DATE=$O(^ECH("AC",DATE)) Q:('DATE)!(DATE>ECED)  D
 .S ECFN=0 F  S ECFN=$O(^ECH("AC",DATE,ECFN)) Q:'ECFN  D
 ..Q:'$D(^ECH(ECFN,"R"))  S ECEC=$G(^ECH(ECFN,0)) Q:ECEC=""
 ..S ECL=$P(ECEC,U,4),ECD=$P(ECEC,U,7),ECPX=$P(ECEC,U,9)
 ..S ECDFN=$P(ECEC,U,2)
 ..I (ECL="")!(ECD="")!(ECPX="")!(ECDFN="") Q
 ..I '$D(NLOC(ECL))!('$D(NDSSUNT(ECD))) Q  ;152  - Not on Location or DSS Units selected list
 ..S ECSTR=ECFN_U_$P(ECEC,U,8)_U_ECPX
 ..S ECNT=ECNT+1,^TMP("ECNTPCE",$J,DATE,ECL,ECD,ECDFN,ECNT)=ECSTR
 ..K ECPRV S ECPRV=$$GETPRV^ECPRVMUT(ECFN,.ECPRV) I 'ECPRV D  K ECPRV
 ...M ^TMP("ECNTPCE",$J,DATE,ECL,ECD,ECDFN,ECNT,"PRV")=ECPRV
 I $G(ECPTYP)="E" D PRT Q  ;119
 D HDR
 I '$O(^TMP("ECNTPCE",$J,0)) D  Q
 .W !!,?10,"No Data found during the time selected."
 D PRT
 Q
 ;
END K ECSD,ECED
 I $D(ECGUI) D ^ECKILL Q
 W !
 I $E(IOST,1,2)="C-",$G(ECOUT)=0 W !!,"Press <RET> to continue" R X:DTIME
 ;W @IOF
 D ^%ZISC D ^ECKILL S:$D(ZTQUEUED) ZTREQ="@"
 Q
PAGE ; end of page
 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECOUT=1 Q
 I $O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT))'="" D HDR ;152 to prevent printing just a header on the last page
 Q
HDR ; print header
 W @IOF
 W ECRDT,?70,"Page: ",ECPG,!
 W !,?17,"ECS RECORDS FAILING TRANSMISSION TO PCE REPORT",!,?24
 W "FROM "_$P(ECDATE,U)_" TO "_$P(ECDATE,U,2),!!
 W "DATE/TIME",?16,"PATIENT",?39,"SSN",?44,"PROVIDER(S)",?61,"REASONS"
 W !,"LOCATION",?16,"PROCEDURE",!,"DSS UNIT",?16,"CATEGORY",!
 F LINE=1:1:80 W "-"
 W !
 S ECPG=ECPG+1
 Q
 ;
PRT N ECLN,ECDN,ECPAT,ECEC,ECPS,ECDFN,ECUN,ECUN1,ECUN2,ECDTE,ECDT,ECRS,ECDE
 N ECX,ECAT,ECSSN,DFN,VA,VADM,ECEPN,ECECPT ;119
 S ECDTE=0 F  S ECDTE=$O(^TMP("ECNTPCE",$J,ECDTE)) Q:'ECDTE  D  Q:ECOUT
 .S ECDT=$$FMTE^XLFDT(ECDTE,2),ECL=0
 .F  S ECL=$O(^TMP("ECNTPCE",$J,ECDTE,ECL)) Q:'ECL  D  Q:ECOUT
 ..S ECLN=$P($G(^DIC(4,ECL,0)),U),ECLN=$S(ECLN="":"UNKNOWN",1:ECLN),ECD=0
 ..F  S ECD=$O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD)) Q:'ECD  D  Q:ECOUT
 ...S ECDN=$P($G(^ECD(ECD,0)),U),ECDN=$S(ECDN="":"UNKNOWN",1:ECDN)
 ...S ECDFN=0
 ...F  S ECDFN=$O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN)) Q:'ECDFN  D  Q:ECOUT
 ....S DFN=ECDFN D DEM^VADPT
 ....S ECPAT=VADM(1),ECSSN=$P($P(VADM(2),U,2),"-",3),ECNT=0
 ....F  S ECNT=$O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT)) Q:'ECNT  D PR2  Q:ECOUT
 Q
 ;
PR2 S ECEC=$G(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT))
 S ECPS="",ECFN=$P(ECEC,U)
 D PROV
 S ECAT=$S($P(ECEC,U,2):$P($G(^EC(726,$P(ECEC,U,2),0)),U),1:"")
 I $P(ECEC,U,3)'="" S ECDE=+$P(ECEC,U,3) D
 .I $P(ECEC,U,3)[";EC" D  Q
 ..S ECPS=$G(^EC(725,+ECDE,0)),ECEPN=$P(ECPS,U),ECECPT=$P(ECPS,U,2),ECPS=$P(ECPS,U,2)_" "_$P(ECPS,U) ;119
 .S ECPS=$$CPT^ICPTCOD(ECDE,ECDTE),ECEPN=$S(+ECPS:$P(ECPS,U,3),1:"CPT NAME UNKNOWN"),ECECPT=$P(ECPS,U,2) ;119
 .S ECPS=$S(+ECPS>0:$P(ECPS,U,2)_" "_$P(ECPS,U,3),1:"CPT NAME UNKNOWN")
 S ECRS=^ECH(ECFN,"R")
 I $G(ECPTYP)="E" D EXPORT K ECPRV Q  ;119
 W ECDT,?16,$E(ECPAT,1,20),?39,ECSSN,?44,$E(ECUN1,1,16),?61,$E($P(ECRS,";"),1,19),!
 W $E(ECLN,1,15),?16,$E(ECPS,1,27),?44,$E(ECUN2,1,16)
 W ?61,$E($P(ECRS,";",2),1,19),!
 W $E(ECDN,1,15),?16,$E(ECAT,1,27),?44,$E(ECUN3,1,16)
 W ?61,$E($P(ECRS,";",3),1,198)
 S ECUN=0 F ECX=4:1 S ECUN=$O(ECPRV(ECUN)) Q:(ECUN="")&($P(ECRS,";",ECX)="")  D  I ECOUT Q
 .W !
 .I ($Y+6)>IOSL D PAGE I ECOUT Q
 .I ECUN'="" W ?44,$E($P(ECPRV(ECUN),"^",2),1,16) K ECPRV(ECUN)
 .W ?61,$E($P(ECRS,";",ECX),1,19)
 W !!
 I ($Y+6)>IOSL D PAGE I ECOUT Q
 Q
PROV ;Set provider 1-3 in variables
 M ECPRV=^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT,"PRV")
 S ECUN=0,ECUN1="UNKNOWN",(ECUN2,ECUN3)=""
 F I=1:1:3 S ECUN=$O(ECPRV(ECUN)) Q:'ECUN  D
 .S @("ECUN"_I)=$P(ECPRV(ECUN),"^",2) K ECPRV(ECUN)
 Q
 ;
EXPORT ;Section added in patch 119
 N J
 S CNT=CNT+1
 S ^TMP($J,"ECRPT",CNT)=ECDT_U_ECLN_U_ECDN_U_ECAT_U_ECPAT_U_ECSSN_U_ECECPT_U_ECEPN_U_ECUN1_U_ECUN2_U_ECUN3
 F J=4:1:7 S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_U_$P($G(ECPRV(J)),U,2) ;Set providers 4 through 7
 F J=1:1:3 S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_U_$P(ECRS,";",J) ;add up to 3 reasons
 Q
 
--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECNTPCE   5771     printed  Sep 23, 2025@19:33:57                                                                                                                                                                                                     Page 2
ECNTPCE   ;ALB/JAM-Event Capture Records failing transmission to PCE;Sep 24, 2020@14:55:55
 +1       ;;2.0;EVENT CAPTURE;**61,72,119,152**;8 May 96;Build 19
EN        ; entry point
 +1        KILL %DT
           SET %DT="AEX"
           SET %DT("A")="Start with Date:  "
           DO ^%DT
           IF Y<0
               GOTO END
 +2        SET ECSD=Y
           SET %DT("A")="End with Date:  "
           DO ^%DT
           if Y<0
               GOTO END
           SET ECED=Y
 +3        IF ECED<ECSD
               WRITE !,"End date must be after start date",!
               GOTO EN
 +4        SET ECDATE=$$FMTE^XLFDT(ECSD)_U_$$FMTE^XLFDT(ECED)
 +5        SET ECSD=ECSD-.0001
           SET ECED=ECED+.9999
 +6        KILL IOP,%ZIS,POP,IO("Q")
           SET %ZIS("A")="Select Device: "
           SET %ZIS="QM"
 +7        DO ^%ZIS
           if POP
               GOTO END
 +8        IF $DATA(IO("Q"))
               KILL IO("Q")
               Begin DoDot:1
 +9                SET (ZTSAVE("ECDFN"),ZTSAVE("ECDATE"),ZTSAVE("ECED"),ZTSAVE("ECSD"))=""
 +10               SET ZTDESC="ECS RECORDS FAILING TRANSMISSION TO PCE REPORT"
                   SET ZTRTN="START^ECNTPCE"
 +11               SET ZTIO=ION
                   DO ^%ZTLOAD
                   DO HOME^%ZIS
               End DoDot:1
               GOTO END
 +12       WRITE !,?5,"Please be patient, this may take a few moments..."
 +13      ;
START     ; entry when queued
 +1       ;119
           NEW ECOUT,X,Y,DIR,LINE,ECPG,ECRDT,%H,CNT
 +2        SET ECOUT=0
           SET ECPG=1
 +3        SET %H=$HOROLOG
           DO YX^%DTC
           SET ECRDT=Y
 +4        USE IO
 +5       ;119
           IF $GET(ECPTYP)="E"
               SET CNT=1
               SET ^TMP($JOB,"ECRPT",CNT)="DATE/TIME^LOCATION^DSS UNIT^CATEGORY^PATIENT^SSN^PROCEDURE CODE^PROCEDURE NAME^PROV 1^PROV 2^PROV 3^PROV 4^PROV 5^PROV 6^PROV 7^REASON 1^REASON 2^REASON 3"
 +6       ;119 get data to export and stop processing.
           IF $GET(ECPTYP)="E"
               DO GET
               DO ^ECKILL
               QUIT 
 +7        DO GET
 +8        DO END
 +9        QUIT 
GET       ; start processing or records
 +1        NEW DATE,ECL,ECNT,ECFN,ECEC,ECPX,ECSTR,ECD
 +2       ;152
           NEW NLOC,NDSSUNT,JJ
 +3        KILL ^TMP("ECNTPCE",$JOB)
 +4       ;***152 Begins
 +5       ;Set locations and  dss units into ien subscripted arrays
 +6        SET JJ=""
           FOR 
               SET JJ=$ORDER(ECLOC(JJ))
               if JJ=""
                   QUIT 
               Begin DoDot:1
 +7                SET NLOC($PIECE(ECLOC(JJ),U,1))=$PIECE(ECLOC(JJ),U,2)
               End DoDot:1
 +8        SET JJ=""
           FOR 
               SET JJ=$ORDER(ECDSSU(JJ))
               if JJ=""
                   QUIT 
               Begin DoDot:1
 +9                SET NDSSUNT($PIECE(ECDSSU(JJ),U,1))=$PIECE(ECDSSU(JJ),U,2)
               End DoDot:1
 +10      ;***152 Ends
 +11       SET DATE=ECSD
           SET ECNT=0
 +12       FOR 
               SET DATE=$ORDER(^ECH("AC",DATE))
               if ('DATE)!(DATE>ECED)
                   QUIT 
               Begin DoDot:1
 +13               SET ECFN=0
                   FOR 
                       SET ECFN=$ORDER(^ECH("AC",DATE,ECFN))
                       if 'ECFN
                           QUIT 
                       Begin DoDot:2
 +14                       if '$DATA(^ECH(ECFN,"R"))
                               QUIT 
                           SET ECEC=$GET(^ECH(ECFN,0))
                           if ECEC=""
                               QUIT 
 +15                       SET ECL=$PIECE(ECEC,U,4)
                           SET ECD=$PIECE(ECEC,U,7)
                           SET ECPX=$PIECE(ECEC,U,9)
 +16                       SET ECDFN=$PIECE(ECEC,U,2)
 +17                       IF (ECL="")!(ECD="")!(ECPX="")!(ECDFN="")
                               QUIT 
 +18      ;152  - Not on Location or DSS Units selected list
                           IF '$DATA(NLOC(ECL))!('$DATA(NDSSUNT(ECD)))
                               QUIT 
 +19                       SET ECSTR=ECFN_U_$PIECE(ECEC,U,8)_U_ECPX
 +20                       SET ECNT=ECNT+1
                           SET ^TMP("ECNTPCE",$JOB,DATE,ECL,ECD,ECDFN,ECNT)=ECSTR
 +21                       KILL ECPRV
                           SET ECPRV=$$GETPRV^ECPRVMUT(ECFN,.ECPRV)
                           IF 'ECPRV
                               Begin DoDot:3
 +22                               MERGE ^TMP("ECNTPCE",$JOB,DATE,ECL,ECD,ECDFN,ECNT,"PRV")=ECPRV
                               End DoDot:3
                               KILL ECPRV
                       End DoDot:2
               End DoDot:1
 +23      ;119
           IF $GET(ECPTYP)="E"
               DO PRT
               QUIT 
 +24       DO HDR
 +25       IF '$ORDER(^TMP("ECNTPCE",$JOB,0))
               Begin DoDot:1
 +26               WRITE !!,?10,"No Data found during the time selected."
               End DoDot:1
               QUIT 
 +27       DO PRT
 +28       QUIT 
 +29      ;
END        KILL ECSD,ECED
 +1        IF $DATA(ECGUI)
               DO ^ECKILL
               QUIT 
 +2        WRITE !
 +3        IF $EXTRACT(IOST,1,2)="C-"
               IF $GET(ECOUT)=0
                   WRITE !!,"Press <RET> to continue"
                   READ X:DTIME
 +4       ;W @IOF
 +5        DO ^%ZISC
           DO ^ECKILL
           if $DATA(ZTQUEUED)
               SET ZTREQ="@"
 +6        QUIT 
PAGE      ; end of page
 +1        IF $EXTRACT(IOST,1,2)="C-"
               SET DIR(0)="E"
               DO ^DIR
               KILL DIR
               IF 'Y
                   SET ECOUT=1
                   QUIT 
 +2       ;152 to prevent printing just a header on the last page
           IF $ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN,ECNT))'=""
               DO HDR
 +3        QUIT 
HDR       ; print header
 +1        WRITE @IOF
 +2        WRITE ECRDT,?70,"Page: ",ECPG,!
 +3        WRITE !,?17,"ECS RECORDS FAILING TRANSMISSION TO PCE REPORT",!,?24
 +4        WRITE "FROM "_$PIECE(ECDATE,U)_" TO "_$PIECE(ECDATE,U,2),!!
 +5        WRITE "DATE/TIME",?16,"PATIENT",?39,"SSN",?44,"PROVIDER(S)",?61,"REASONS"
 +6        WRITE !,"LOCATION",?16,"PROCEDURE",!,"DSS UNIT",?16,"CATEGORY",!
 +7        FOR LINE=1:1:80
               WRITE "-"
 +8        WRITE !
 +9        SET ECPG=ECPG+1
 +10       QUIT 
 +11      ;
PRT        NEW ECLN,ECDN,ECPAT,ECEC,ECPS,ECDFN,ECUN,ECUN1,ECUN2,ECDTE,ECDT,ECRS,ECDE
 +1       ;119
           NEW ECX,ECAT,ECSSN,DFN,VA,VADM,ECEPN,ECECPT
 +2        SET ECDTE=0
           FOR 
               SET ECDTE=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE))
               if 'ECDTE
                   QUIT 
               Begin DoDot:1
 +3                SET ECDT=$$FMTE^XLFDT(ECDTE,2)
                   SET ECL=0
 +4                FOR 
                       SET ECL=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL))
                       if 'ECL
                           QUIT 
                       Begin DoDot:2
 +5                        SET ECLN=$PIECE($GET(^DIC(4,ECL,0)),U)
                           SET ECLN=$SELECT(ECLN="":"UNKNOWN",1:ECLN)
                           SET ECD=0
 +6                        FOR 
                               SET ECD=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD))
                               if 'ECD
                                   QUIT 
                               Begin DoDot:3
 +7                                SET ECDN=$PIECE($GET(^ECD(ECD,0)),U)
                                   SET ECDN=$SELECT(ECDN="":"UNKNOWN",1:ECDN)
 +8                                SET ECDFN=0
 +9                                FOR 
                                       SET ECDFN=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN))
                                       if 'ECDFN
                                           QUIT 
                                       Begin DoDot:4
 +10                                       SET DFN=ECDFN
                                           DO DEM^VADPT
 +11                                       SET ECPAT=VADM(1)
                                           SET ECSSN=$PIECE($PIECE(VADM(2),U,2),"-",3)
                                           SET ECNT=0
 +12                                       FOR 
                                               SET ECNT=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN,ECNT))
                                               if 'ECNT
                                                   QUIT 
                                               DO PR2
                                               if ECOUT
                                                   QUIT 
                                       End DoDot:4
                                       if ECOUT
                                           QUIT 
                               End DoDot:3
                               if ECOUT
                                   QUIT 
                       End DoDot:2
                       if ECOUT
                           QUIT 
               End DoDot:1
               if ECOUT
                   QUIT 
 +13       QUIT 
 +14      ;
PR2        SET ECEC=$GET(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN,ECNT))
 +1        SET ECPS=""
           SET ECFN=$PIECE(ECEC,U)
 +2        DO PROV
 +3        SET ECAT=$SELECT($PIECE(ECEC,U,2):$PIECE($GET(^EC(726,$PIECE(ECEC,U,2),0)),U),1:"")
 +4        IF $PIECE(ECEC,U,3)'=""
               SET ECDE=+$PIECE(ECEC,U,3)
               Begin DoDot:1
 +5                IF $PIECE(ECEC,U,3)[";EC"
                       Begin DoDot:2
 +6       ;119
                           SET ECPS=$GET(^EC(725,+ECDE,0))
                           SET ECEPN=$PIECE(ECPS,U)
                           SET ECECPT=$PIECE(ECPS,U,2)
                           SET ECPS=$PIECE(ECPS,U,2)_" "_$PIECE(ECPS,U)
                       End DoDot:2
                       QUIT 
 +7       ;119
                   SET ECPS=$$CPT^ICPTCOD(ECDE,ECDTE)
                   SET ECEPN=$SELECT(+ECPS:$PIECE(ECPS,U,3),1:"CPT NAME UNKNOWN")
                   SET ECECPT=$PIECE(ECPS,U,2)
 +8                SET ECPS=$SELECT(+ECPS>0:$PIECE(ECPS,U,2)_" "_$PIECE(ECPS,U,3),1:"CPT NAME UNKNOWN")
               End DoDot:1
 +9        SET ECRS=^ECH(ECFN,"R")
 +10      ;119
           IF $GET(ECPTYP)="E"
               DO EXPORT
               KILL ECPRV
               QUIT 
 +11       WRITE ECDT,?16,$EXTRACT(ECPAT,1,20),?39,ECSSN,?44,$EXTRACT(ECUN1,1,16),?61,$EXTRACT($PIECE(ECRS,";"),1,19),!
 +12       WRITE $EXTRACT(ECLN,1,15),?16,$EXTRACT(ECPS,1,27),?44,$EXTRACT(ECUN2,1,16)
 +13       WRITE ?61,$EXTRACT($PIECE(ECRS,";",2),1,19),!
 +14       WRITE $EXTRACT(ECDN,1,15),?16,$EXTRACT(ECAT,1,27),?44,$EXTRACT(ECUN3,1,16)
 +15       WRITE ?61,$EXTRACT($PIECE(ECRS,";",3),1,198)
 +16       SET ECUN=0
           FOR ECX=4:1
               SET ECUN=$ORDER(ECPRV(ECUN))
               if (ECUN="")&($PIECE(ECRS,";",ECX)="")
                   QUIT 
               Begin DoDot:1
 +17               WRITE !
 +18               IF ($Y+6)>IOSL
                       DO PAGE
                       IF ECOUT
                           QUIT 
 +19               IF ECUN'=""
                       WRITE ?44,$EXTRACT($PIECE(ECPRV(ECUN),"^",2),1,16)
                       KILL ECPRV(ECUN)
 +20               WRITE ?61,$EXTRACT($PIECE(ECRS,";",ECX),1,19)
               End DoDot:1
               IF ECOUT
                   QUIT 
 +21       WRITE !!
 +22       IF ($Y+6)>IOSL
               DO PAGE
               IF ECOUT
                   QUIT 
 +23       QUIT 
PROV      ;Set provider 1-3 in variables
 +1        MERGE ECPRV=^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN,ECNT,"PRV")
 +2        SET ECUN=0
           SET ECUN1="UNKNOWN"
           SET (ECUN2,ECUN3)=""
 +3        FOR I=1:1:3
               SET ECUN=$ORDER(ECPRV(ECUN))
               if 'ECUN
                   QUIT 
               Begin DoDot:1
 +4                SET @("ECUN"_I)=$PIECE(ECPRV(ECUN),"^",2)
                   KILL ECPRV(ECUN)
               End DoDot:1
 +5        QUIT 
 +6       ;
EXPORT    ;Section added in patch 119
 +1        NEW J
 +2        SET CNT=CNT+1
 +3        SET ^TMP($JOB,"ECRPT",CNT)=ECDT_U_ECLN_U_ECDN_U_ECAT_U_ECPAT_U_ECSSN_U_ECECPT_U_ECEPN_U_ECUN1_U_ECUN2_U_ECUN3
 +4       ;Set providers 4 through 7
           FOR J=4:1:7
               SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_U_$PIECE($GET(ECPRV(J)),U,2)
 +5       ;add up to 3 reasons
           FOR J=1:1:3
               SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_U_$PIECE(ECRS,";",J)
 +6        QUIT