source: FOIAVistA/tag/r/MEDICINE-MC/MCARGD.m@ 628

MCARGD ;WISC/TJK-DIAGNOSIS FILTER ;3/11/96  12:06
 ;;2.3;Medicine;;09/13/1996
 G EXIT:$D(DUOUT)!($D(DTOUT))
PROC 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))
 D ARR G COM:'$D(V)
PRIM G PRIM1:J>1
 S DIR("A")="Do you wish to enter this diagnosis as the primary diagnosis"
 S DIR("B")="Y",DIR(0)="Y"
 D ^DIR
 G EXIT:$G(DIRUT),SEC:'Y
 S Z=1
 G PRIM2
PRIM1 W !!,"Enter Primary Diagnosis (1-",J,"): " R Z:DTIME G EXIT:'$T,EXIT:Z=U
 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
 G SEC:Z="" I '$D(V(Z)) W *7," ??" G PRIM1
PRIM2 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)
SEC S MCARTY="Secondary" D ARR G COM:'$D(V) K DR
 W !!,"Enter Number of Secondary Diagnosis or 'ALL' to enter all: "
 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
 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."
 I '$D(V(Z)) W *7," ??" G SEC
 S ZI=Z D SECSET K ZI G EXIT:$D(DTOUT),EXIT:$D(Y) G SEC
COM K DR,DIC,DIE,DA S DIE="^MCAR(699,",DA=MCARGDA,DR="37.1"
 ;MFD 3/10/93 ;700",DR(2,699.03)=.01
 D ^DIE G EXIT:$D(DTOUT),EXIT:$D(Y)
REV G EXIT:'$D(^MCAR(699,MCARGDA,204))
 K DR S DR=38 D ^DIE G EXIT
EDIT S DR="204;205" D ^DIE G EXIT:$D(DTOUT),EXIT:$D(Y)
 G SEC
SECSET 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,"
 I $D(^MCAR(699,MCARGDA,27,"B",V(ZI))) S DA=$O(^(V(ZI),0)),DR=".01;1" G SECSET1
 S DR=".01///"_V(ZI)_";1" F DA=1:1 Q:'$D(^MCAR(699,MCARGDA,27,DA))
 S $P(^MCAR(699,MCARGDA,27,0),U,3)=DA,$P(^(0),U,4)=$P(^(0),U,4)+1
SECSET1 W !,X D ^DIE Q
ARR K V,A S J=0
 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
 Q
CHECK I '$D(^MCAR(699,MCARGDA,204)) Q
 I $D(^MCAR(699,MCARGDA,204)),^(204)'=K Q
 Q
LIST 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"
 Q
ENTERED I $D(^MCAR(699,MCARGDA,27,"B",K)) W "   ****ENTERED****"
 Q
DPT ;
 S MCPRO=$S(MCARCODE="P":"PULM",1:"GI")
 D MCEPROC^MCARE
 S DIC="^MCAR(699,",DIC(0)="AEQMZ",MCFILE=699
 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))"
 I MCESON S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
 S DIC("A")="Select Patient Name or Date/Time of Appointment: "
 D ^DIC K DIC("S"),DIC("A")
 G EXIT:Y<0
 S MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCFILE=699
 I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,MCARGDA) I '$D(MCBACK) G EXIT ;RMP CHANGED () EXPRESSION FROM >2
 I $D(MCBACK) D BACK^MCARGE
 S DFN=$P(Y(0),U,2),MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U)
 D ORDER^MCARGEO G EXIT:$D(DTOUT)!$D(DUOUT)
 D PROC,ORDER1^MCARGEO,QTASK^MCPARAM
 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
 K MCARGDA,MCARGNUM,MCFILE,MCARGNON,UNSIGNED
EXIT ;
 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
EN1 ;CALLED BY X-REF TO DELETE SECONDARY DIAGNOSIS WHEN IMPRESSION IS DELETED
 N I,J
 S I=$O(^MCAR(699,DA(1),27,"B",X,0)) Q:'I
 K ^MCAR(699,DA(1),27,I),^MCAR(699,DA(1),27,"B",X,I)
 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