source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECEDF.m@ 1800

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

initial load of WorldVistAEHR

File size: 5.2 KB
RevLine 
[613]1ECEDF ;BIR/MAM,JPW-Enter Event Capture Data (cont'd) ;6 Mar 96
2 ;;2.0; EVENT CAPTURE ;**4,5,10,13,18,23,33,72**;8 May 96
3FILE ;file proc
4 L +^ECH(0) S ECRN=$P(^ECH(0),"^",3)+1 I $D(^ECH(ECRN)) S $P(^ECH(0),"^",3)=$P(^(0),"^",3)+1 L -^ECH(0) G FILE
5 L -^ECH(0) K DA,DD,DO,DIC S DIC(0)="L",DIC="^ECH(",X=ECRN D FILE^DICN K DIC S ECFN=+Y
6 ;Ask and file CPT modifiers, ALB/JAM
7 S ECCPT=$S(ECP["ICPT":+ECP,1:$P($G(^EC(725,+ECP,0)),U,5)) I ECCPT D
8 . S ECMODS=$G(ECMODS)
9 . S ECMODF=$$ASKMOD^ECUTL(ECCPT,ECMODS,ECDT,.ECMOD,.ECERR)
10 . S:$G(ECERR) ECOUT=1 K ECMODF,ECMODS I ECOUT Q
11 . S MOD="" F S MOD=$O(ECMOD(ECCPT,MOD)) Q:MOD="" D
12 . . S MODIEN=$P(ECMOD(ECCPT,MOD),U,2) I MODIEN<0 Q
13 . . K DIC,DD,DO S DIC(0)="L",DA(1)=ECFN,DIC("P")=$P(^DD(721,36,0),U,2)
14 . . S X=MODIEN,DIC="^ECH("_DA(1)_","_"""MOD"""_"," D FILE^DICN
15 . K MOD,MODIEN,DIC,ECMOD
16 I $G(ECOUT) K ECMODS,ECMOD,ECERR D RECDEL,MSG Q
17 S DIR("A")="Volume",DIR("B")=ECVOL,DIR(0)="N^^K:(X<1)!(X>99) X"
18 S DIR("?")="Type a Number between 1 and 99, 0 Decimal Digits"
19 D ^DIR I $D(DIRUT) K DIR D RECDEL,MSG Q
20 S ECVOL=+Y,ECNULL="" K DIR
21 K DA,DR,DIE S DIE("NO^")="OUTOK",DIE="^ECH(",DA=ECFN
22 S DR="1////"_ECDFN_";3////"_ECL_";4////"_ECS_";5////"_ECM_";6////"_ECD_";7////"_+ECC_";9////"_ECVOL_";Q;8////"_ECNULL D ^DIE K DR
23 I $D(DTOUT)!($D(Y)'=0) K DIE D RECDEL,MSG Q
24 ;
25 ;- Default to previous ordering section if >1 procedure entered
26 S ECODFN=+$G(ECODFN)
27 S ECMN=$S((ECODFN=ECDFN)&(+$G(ECOM)):$P($G(^ECC(723,ECOM,0)),"^"),1:$P($G(^ECC(723,ECM,0)),"^"))
28 ;
29 ;- Get ordering section, and Procedure Date/Time
30 S DR="11//"_ECMN_";2////"_ECDT
31 D ^DIE K DR
32 I $D(DTOUT)!($D(Y)'=0)!($P(^ECH(ECFN,0),"^",3)="") K DIE D RECDEL,MSG Q
33 ;
34 ;- Get associated clinic
35 I $$CHKDSS^ECUTL0(+$G(ECD),ECPTSTAT) D I +$G(ECOUT) D RECDEL,MSG Q
36 . S DR=$S(EC4N]"":"26//"_EC4N,1:"26")
37 . D ^DIE S EC4=X K DR
38 . I $D(DTOUT)!($D(Y)'=0) K DIE S ECOUT=1
39 ;
40 ; Get primary and multiple secondary diagnosis codes, ALB/JAM
41 I $P(ECPCE,"~",2)'="N" D I ECOUT D RECDEL,MSG Q
42 . D DIAG^ECUTL2 I ECOUT Q
43 . S DA=ECFN,DR=$S(ECDX]"":"20////"_ECDX,1:20) D ^DIE S ECDXY=X K DR
44 . S DXS="" F S DXS=$O(ECDXS(DXS)) Q:DXS="" D
45 . . S DXSIEN=$P(ECDXS(DXS),U) I DXSIEN<0 Q
46 . . K DIC,DD,DO S DIC(0)="L",DA(1)=ECFN,DIC("P")=$P(^DD(721,38,0),U,2)
47 . . S X=DXSIEN,DIC="^ECH("_DA(1)_","_"""DX"""_"," D FILE^DICN
48 . K ECDXX M ECDXX=ECDXS K DXS,DXSIEN,DIC,ECDXS
49 . ; Update all procedures for an encounter with same primary & second dx
50 . S PXUPD=$$PXUPD^ECUTL2(ECDFN,ECDT,ECL,EC4,ECDXY,.ECDXX,ECFN)
51 . K PXUPD,ECDXY,ECDXX
52 S DA=ECFN
53 ;
54 ;- Determine patient eligibility
55 I $$CHKDSS^ECUTL0(+$G(ECD),ECPTSTAT) D
56 . I $$MULTELG^ECUTL0(+$G(ECDFN)) S ECELIG=+$$ELGLST^ECUTL0
57 . E S ECELIG=+$G(VAEL(1))
58 K VAEL
59 ;
60 ;- File inpatient/outpatient status
61 S DR="29////"_ECPTSTAT
62 D ^DIE K DR
63 ;
64 ;- Ask classification questions applicable to patient and file in #721
65 I $$ASKCLASS^ECUTL1(+$G(ECDFN),.ECCLFLDS,.ECOUT,ECPCE,ECPTSTAT),($O(ECCLFLDS(""))]"") D EDCLASS^ECUTL1(ECFN,.ECCLFLDS)
66 I +$G(ECOUT) K DIE D RECDEL,MSG Q
67 K ECCLFLDS
68 ;
69 ;;get provider(s) with active person class
70 D ASKPRV^ECPRVMUT(ECFN,ECDT,.ECPRVARY,.ECOUT)
71 I +$G(ECOUT) K DIE D RECDEL,MSG Q
72 S ECFIL=$$FILPRV^ECPRVMUT(ECFN,.ECPRVARY,.ECOUT)
73 K ECFIL,ECPRVARY,ECPRV,ECPRVN
74 I +$G(ECOUT) K DIE D RECDEL,MSG Q
75 ;
76 ;- File assoc clinic from event code screen if null
77 I $P($G(^ECH(ECFN,0)),"^",19)="" D
78 . I $G(EC4)="" D GETCLN
79 . S EC4=+$G(EC4)
80 . I EC4>0 D
81 .. S DA=ECFN,DR="26////^S X=EC4"
82 .. D ^DIE K DA,DR,DIE
83 ;
84 K DA,DR,DIE,ECNULL
85 ;
86 ;- Set vars and default to prev ordering section if >1 proc entered
87 S EC4=$P(^ECH(ECFN,0),"^",19),ECINP=$P(^(0),"^",22),ECOM=$P(^(0),"^",12),ECID=$P($G(^SC(+EC4,0)),"^",7),ECODFN=ECDFN
88 ;
89 I $P(ECPCE,"~",2)="N" G FILE2
90 I ($P(ECPCE,"~",2)="O")&(ECINP'="O") G FILE2
91 D CLIN I 'ECPCL W !!,"You should edit this patient procedure and enter an active clinic." W:'$D(ECIOFLG) !!,"Press <RET> to continue " R X:DTIME
92FILE2 ;continue
93 S $P(^ECH(ECFN,0),"^",13)=DUZ,$P(^(0),"^",9)=ECP,$P(^(0),"^",20)=ECID,ECINP=$P(^(0),"^",22),ECDX=+$P($G(^("P")),"^",2)
94 S ECCPT=$S(ECP["EC":$P($G(^EC(725,+ECP,0)),"^",5),1:+ECP)
95 S $P(^ECH(ECFN,"P"),"^")=ECCPT
96 ;
97 ;- Procedure Reason(s)
98 I $G(ECP)]"" S ECSCR=+$O(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0))
99 I ECSCR>0,($P($G(^ECJ(ECSCR,"PRO")),"^",5)=1),(+$O(^ECL("AD",ECSCR,0))) D Q:+$G(ECOUT)
100 . S DIE="^ECH(",DA=ECFN,DR="34" D ^DIE K DA,DR,DIE
101 . I $D(DTOUT)!($D(Y)'=0) K ECSCR D RECDEL,MSG Q
102 K ECSCR
103 ;
104PCE ; format PCE data to send
105 Q:$P(ECPCE,"~",2)="N" I $P(ECPCE,"~",2)="O"&(ECINP'="O") Q
106 D PCE^ECBEN2U
107 Q
108MSG ;
109 W !!,"All information was not entered. This procedure has been deleted.",!!,"Press <RET> to continue " R X:DTIME S ECOUT=1
110 Q
111CLIN ;check for active associated clinic
112 S MSG1=1,MSG2=0
113 I 'EC4 S MSG2=1
114 D CLIN^ECPCEU
115 I 'ECPCL D
116 .W !!,"The clinic ",$S(MSG1:"associated with",1:"you selected for")," this procedure ",$S(MSG2:"has not been entered",1:"is inactive"),"."
117 .W !,"Workload data cannot be sent to PCE for this procedure with ",!,$S(MSG2:"a missing",1:"an inactive")," clinic."
118 S (MSG1,MSG2)=0
119 Q
120 ;
121GETCLN ;- Get assoc clinic from event code screen
122 N ECI
123 I $G(EC4)="",($G(ECP)]"") D
124 . S ECI=+$O(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0)),EC4=+$P($G(^ECJ(+ECI,"PRO")),"^",4)
125 . S EC4N=$S($P($G(^SC(+EC4,0)),"^")]"":$P(^(0),"^"),1:"")
126 Q
127 ;
128RECDEL ; Delete record
129 ;
130 N DA,DIK
131 S DA=ECFN,DIK="^ECH(" D ^DIK
132 Q
Note: See TracBrowser for help on using the repository browser.