source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECNTPCE.m@ 1604

Last change on this file since 1604 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.1 KB
RevLine 
[613]1ECNTPCE ;ALB/JAM-Event Capture Records failing transmission to PCE;14 Jan 04
2 ;;2.0; EVENT CAPTURE ;**61,72**;8 May 96
3EN ; entry point
4 K %DT S %DT="AEX",%DT("A")="Start with Date: " D ^%DT I Y<0 G END
5 S ECSD=Y,%DT("A")="End with Date: " D ^%DT G:Y<0 END S ECED=Y
6 I ECED<ECSD W !,"End date must be after start date",! G EN
7 S ECDATE=$$FMTE^XLFDT(ECSD)_U_$$FMTE^XLFDT(ECED)
8 S ECSD=ECSD-.0001,ECED=ECED+.9999
9 K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Select Device: ",%ZIS="QM"
10 D ^%ZIS G:POP END
11 I $D(IO("Q")) K IO("Q") D G END
12 .S (ZTSAVE("ECDFN"),ZTSAVE("ECDATE"),ZTSAVE("ECED"),ZTSAVE("ECSD"))=""
13 .S ZTDESC="ECS RECORDS FAILING TRANSMISSION TO PCE REPORT",ZTRTN="START^ECNTPCE"
14 .S ZTIO=ION D ^%ZTLOAD,HOME^%ZIS
15 W !,?5,"Please be patient, this may take a few moments..."
16 ;
17START ; entry when queued
18 N ECOUT,X,Y,DIR,LINE,ECPG,ECRDT,%H
19 S ECOUT=0,ECPG=1
20 S %H=$H D YX^%DTC S ECRDT=Y
21 U IO
22 D GET
23 D END
24 Q
25GET ; start processing or records
26 N DATE,ECL,ECNT,ECFN,ECEC,ECPX,ECSTR,ECD
27 K ^TMP("ECNTPCE",$J)
28 S DATE=ECSD,ECNT=0
29 F S DATE=$O(^ECH("AC",DATE)) Q:('DATE)!(DATE>ECED) D
30 .S ECFN=0 F S ECFN=$O(^ECH("AC",DATE,ECFN)) Q:'ECFN D
31 ..Q:'$D(^ECH(ECFN,"R")) S ECEC=$G(^ECH(ECFN,0)) Q:ECEC=""
32 ..S ECL=$P(ECEC,U,4),ECD=$P(ECEC,U,7),ECPX=$P(ECEC,U,9)
33 ..S ECDFN=$P(ECEC,U,2)
34 ..I (ECL="")!(ECD="")!(ECPX="")!(ECDFN="") Q
35 ..S ECSTR=ECFN_U_$P(ECEC,U,8)_U_ECPX
36 ..S ECNT=ECNT+1,^TMP("ECNTPCE",$J,DATE,ECL,ECD,ECDFN,ECNT)=ECSTR
37 ..K ECPRV S ECPRV=$$GETPRV^ECPRVMUT(ECFN,.ECPRV) I 'ECPRV D K ECPRV
38 ...M ^TMP("ECNTPCE",$J,DATE,ECL,ECD,ECDFN,ECNT,"PRV")=ECPRV
39 D HDR
40 I '$O(^TMP("ECNTPCE",$J,0)) D Q
41 .W !!,?10,"No Data found during the time selected."
42 D PRT
43 Q
44 ;
45END K ECSD,ECED
46 I $D(ECGUI) D ^ECKILL Q
47 W !
48 I $E(IOST,1,2)="C-",$G(ECOUT)=0 W !!,"Press <RET> to continue" R X:DTIME
49 ;W @IOF
50 D ^%ZISC D ^ECKILL S:$D(ZTQUEUED) ZTREQ="@"
51 Q
52PAGE ; end of page
53 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECOUT=1 Q
54 D HDR
55 Q
56HDR ; print header
57 W @IOF
58 W ECRDT,?70,"Page: ",ECPG,!
59 W !,?17,"ECS RECORDS FAILING TRANSMISSION TO PCE REPORT",!,?24
60 W "FROM "_$P(ECDATE,U)_" TO "_$P(ECDATE,U,2),!!
61 W "DATE/TIME",?16,"PATIENT",?39,"SSN",?44,"PROVIDER(S)",?61,"REASONS"
62 W !,"LOCATION",?16,"PROCEDURE",!,"DSS UNIT",?16,"CATEGORY",!
63 F LINE=1:1:80 W "-"
64 W !
65 S ECPG=ECPG+1
66 Q
67 ;
68PRT N ECLN,ECDN,ECPAT,ECEC,ECPS,ECDFN,ECUN,ECUN1,ECUN2,ECDTE,ECDT,ECRS,ECDE
69 N ECX,ECAT,ECSSN,DFN,VA,VADM
70 S ECDTE=0 F S ECDTE=$O(^TMP("ECNTPCE",$J,ECDTE)) Q:'ECDTE D Q:ECOUT
71 .S ECDT=$$FMTE^XLFDT(ECDTE,2),ECL=0
72 .F S ECL=$O(^TMP("ECNTPCE",$J,ECDTE,ECL)) Q:'ECL D Q:ECOUT
73 ..S ECLN=$P($G(^DIC(4,ECL,0)),U),ECLN=$S(ECLN="":"UNKNOWN",1:ECLN),ECD=0
74 ..F S ECD=$O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD)) Q:'ECD D Q:ECOUT
75 ...S ECDN=$P($G(^ECD(ECD,0)),U),ECDN=$S(ECDN="":"UNKNOWN",1:ECDN)
76 ...S ECDFN=0
77 ...F S ECDFN=$O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN)) Q:'ECDFN D Q:ECOUT
78 ....S DFN=ECDFN D DEM^VADPT
79 ....S ECPAT=VADM(1),ECSSN=$P($P(VADM(2),U,2),"-",3),ECNT=0
80 ....F S ECNT=$O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT)) Q:'ECNT D PR2 Q:ECOUT
81 Q
82 ;
83PR2 S ECEC=$G(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT))
84 S ECPS="",ECFN=$P(ECEC,U)
85 D PROV
86 S ECAT=$S($P(ECEC,U,2):$P($G(^EC(726,$P(ECEC,U,2),0)),U),1:"")
87 I $P(ECEC,U,3)'="" S ECDE=+$P(ECEC,U,3) D
88 .I $P(ECEC,U,3)[";EC" D Q
89 ..S ECPS=$G(^EC(725,+ECDE,0)),ECPS=$P(ECPS,U,2)_" "_$P(ECPS,U)
90 .S ECPS=$$CPT^ICPTCOD(ECDE,ECDTE)
91 .S ECPS=$S(+ECPS>0:$P(ECPS,U,2)_" "_$P(ECPS,U,3),1:"CPT NAME UNKNOWN")
92 S ECRS=^ECH(ECFN,"R")
93 W ECDT,?16,$E(ECPAT,1,20),?39,ECSSN,?44,$E(ECUN1,1,16),?61,$E($P(ECRS,";"),1,19),!
94 W $E(ECLN,1,15),?16,$E(ECPS,1,27),?44,$E(ECUN2,1,16)
95 W ?61,$E($P(ECRS,";",2),1,19),!
96 W $E(ECDN,1,15),?16,$E(ECAT,1,27),?44,$E(ECUN3,1,16)
97 W ?61,$E($P(ECRS,";",3),1,198)
98 S ECUN=0 F ECX=4:1 S ECUN=$O(ECPRV(ECUN)) Q:(ECUN="")&($P(ECRS,";",ECX)="") D I ECOUT Q
99 .W !
100 .I ($Y+6)>IOSL D PAGE I ECOUT Q
101 .I ECUN'="" W ?44,$E($P(ECPRV(ECUN),"^",2),1,16) K ECPRV(ECUN)
102 .W ?61,$E($P(ECRS,";",ECX),1,19)
103 W !!
104 I ($Y+6)>IOSL D PAGE I ECOUT Q
105 Q
106PROV ;Set provider 1-3 in variables
107 M ECPRV=^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT,"PRV")
108 S ECUN=0,ECUN1="UNKNOWN",(ECUN2,ECUN3)=""
109 F I=1:1:3 S ECUN=$O(ECPRV(ECUN)) Q:'ECUN D
110 .S @("ECUN"_I)=$P(ECPRV(ECUN),"^",2) K ECPRV(ECUN)
111 Q
Note: See TracBrowser for help on using the repository browser.