source: FOIAVistA/trunk/r/MEDICINE-MC/MCARGD.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1MCARGD ;WISC/TJK-DIAGNOSIS FILTER ;3/11/96 12:06
2 ;;2.3;Medicine;;09/13/1996
3 G EXIT:$D(DUOUT)!($D(DTOUT))
4PROC W:$D(MCDFLAG) @IOF W !!?33,"DIAGNOSIS ENTRY",!?33,"--------------",!! S (DIC,DIE)="^MCAR(699,",DA=MCARGDA,MCARTY="Primary" G EDIT:$D(^MCAR(699,MCARGDA,204))
5 D ARR G COM:'$D(V)
6PRIM G PRIM1:J>1
7 S DIR("A")="Do you wish to enter this diagnosis as the primary diagnosis"
8 S DIR("B")="Y",DIR(0)="Y"
9 D ^DIR
10 G EXIT:$G(DIRUT),SEC:'Y
11 S Z=1
12 G PRIM2
13PRIM1 W !!,"Enter Primary Diagnosis (1-",J,"): " R Z:DTIME G EXIT:'$T,EXIT:Z=U
14 I Z?1"?"."?" W !,*7,"Enter Number of Diagnosis That You Wish to Use as Primary Diagnosis",!,"Hit Return if you do not wish to enter any of above" G PRIM1
15 G SEC:Z="" I '$D(V(Z)) W *7," ??" G PRIM1
16PRIM2 S X=V(Z),DR="204///"_X_";205" W !,$P(^MCAR(697.5,X,0),U) D ^DIE G EXIT:$D(DTOUT),EXIT:$D(Y)
17SEC S MCARTY="Secondary" D ARR G COM:'$D(V) K DR
18 W !!,"Enter Number of Secondary Diagnosis or 'ALL' to enter all: "
19 R Z:DTIME G EXIT:'$T,COM:Z="",EXIT:Z=U I Z="ALL" F ZI=0:0 S ZI=$O(V(ZI)) Q:ZI="" D SECSET
20 K ZI G COM:Z="ALL",COM:Z="" I $E(Z)="?" W !,*7,"Enter Number of Diagnosis from above list or enter 'ALL' for All Diagnoses to be entered as a secondary diagnosis."
21 I '$D(V(Z)) W *7," ??" G SEC
22 S ZI=Z D SECSET K ZI G EXIT:$D(DTOUT),EXIT:$D(Y) G SEC
23COM K DR,DIC,DIE,DA S DIE="^MCAR(699,",DA=MCARGDA,DR="37.1"
24 ;MFD 3/10/93 ;700",DR(2,699.03)=.01
25 D ^DIE G EXIT:$D(DTOUT),EXIT:$D(Y)
26REV G EXIT:'$D(^MCAR(699,MCARGDA,204))
27 K DR S DR=38 D ^DIE G EXIT
28EDIT S DR="204;205" D ^DIE G EXIT:$D(DTOUT),EXIT:$D(Y)
29 G SEC
30SECSET K DR,DIE,DIC S:'$D(^MCAR(699,MCARGDA,27)) ^(27,0)="^699.75^0^0" S X=$P(^MCAR(697.5,V(ZI),0),U),DA(1)=MCARGDA,DIE="^MCAR(699,"_MCARGDA_",27,"
31 I $D(^MCAR(699,MCARGDA,27,"B",V(ZI))) S DA=$O(^(V(ZI),0)),DR=".01;1" G SECSET1
32 S DR=".01///"_V(ZI)_";1" F DA=1:1 Q:'$D(^MCAR(699,MCARGDA,27,DA))
33 S $P(^MCAR(699,MCARGDA,27,0),U,3)=DA,$P(^(0),U,4)=$P(^(0),U,4)+1
34SECSET1 W !,X D ^DIE Q
35ARR K V,A S J=0
36 F I=0:0 S I=$O(^MCAR(699,MCARGDA,30,I)) Q:I'?1N.N I $P(^(I,0),U,6) S K=$P(^(0),U,6) D CHECK,LIST
37 Q
38CHECK I '$D(^MCAR(699,MCARGDA,204)) Q
39 I $D(^MCAR(699,MCARGDA,204)),^(204)'=K Q
40 Q
41LIST I $T,'$D(A(K)) S J=J+1 W:J=1 !!,"Possible ",MCARTY," Diagnoses are: " W !,J,". ",$P(^MCAR(697.5,K,0),U) S V(J)=K,A(K)="" D ENTERED:$E(MCARTY)="S"
42 Q
43ENTERED I $D(^MCAR(699,MCARGDA,27,"B",K)) W " ****ENTERED****"
44 Q
45DPT ;
46 S MCPRO=$S(MCARCODE="P":"PULM",1:"GI")
47 D MCEPROC^MCARE
48 S DIC="^MCAR(699,",DIC(0)="AEQMZ",MCFILE=699
49 S DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,$P(^MCAR(699,+Y,0),U,12))),$P(^MCAR(699,+Y,0),U,12)'=$O(^MCAR(697.2,""B"",""NON-ENDO"",0))"
50 I MCESON S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
51 S DIC("A")="Select Patient Name or Date/Time of Appointment: "
52 D ^DIC K DIC("S"),DIC("A")
53 G EXIT:Y<0
54 S MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCFILE=699
55 I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,MCARGDA) I '$D(MCBACK) G EXIT ;RMP CHANGED () EXPRESSION FROM >2
56 I $D(MCBACK) D BACK^MCARGE
57 S DFN=$P(Y(0),U,2),MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U)
58 D ORDER^MCARGEO G EXIT:$D(DTOUT)!$D(DUOUT)
59 D PROC,ORDER1^MCARGEO,QTASK^MCPARAM
60 I $G(MCARGDA)>0 S UNSIGNED=$S($P(^MCAR(MCFILE,MCARGDA,"ES"),U,4)="":1,1:0) D POST^MCESEDT(MCFILE,.MCARGDA) D:UNSIGNED=1 ^MCWORKLD
61 K MCARGDA,MCARGNUM,MCFILE,MCARGNON,UNSIGNED
62EXIT ;
63 K DIC,DIE,DA,I,J,K,V,MCARTY,Z,ZI,A,%,%Y,%Y1,%Y2,C,D,D0,DI,DIPGM,DQ,DR,MCARCODE,X,Y,A,MCPROV Q
64EN1 ;CALLED BY X-REF TO DELETE SECONDARY DIAGNOSIS WHEN IMPRESSION IS DELETED
65 N I,J
66 S I=$O(^MCAR(699,DA(1),27,"B",X,0)) Q:'I
67 K ^MCAR(699,DA(1),27,I),^MCAR(699,DA(1),27,"B",X,I)
68 S I=$P(^MCAR(699,DA(1),27,0),U,3),J=$P(^(0),U,4),$P(^(0),U,3)=I-1,$P(^(0),U,4)=J-1 Q
Note: See TracBrowser for help on using the repository browser.