source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN32.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: 973 bytes
Line 
1YSCEN32 ;ALB/ASF-DRG ;4/4/90 12:47 ;
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 ;
4 ; Called from routines YSCEN3, YSCEN34, YSCEN52
5 ;
6 S:'$D(YSDRGFL) YSDRGFL=0 S:'$D(PTF) PTF=0 D ENPT^YSUTL S AGE=YSAGE,DFN=YSDFN,SEX=YSSEX
7 D OA:'J1 Q:'J1 ;S PTF=$S(PTF:J1,1:$P(^DPT(DFN,"DA",+J1,0),U,12)) S:PTF'?1N.N PTF=0
8 S B(70)=$G(^DGPT(PTF,70)),ICDDMS=$P(B(70),U,3)=4,ICDEXP=0,SEX=$P(^DPT(DFN,0),U,2),ICDTRS=$P(B(70),U,3)=5 I $D(^DPT(DFN,.35)) S:$L(^DPT(DFN,.35)) ICDEXP=1
9 S L8=0 S:$D(^DGPT(PTF,"M",1,0)) L8=$P(^DGPT(PTF,"M",1,0),U,5)
10 I $P(B(70),U,10)>0 S L=$P(B(70),U,10),L7="p" G GRP
11 I L8>0 S L=L8,L7="m" G GRP
12 D PDX^YSCEN6 I 'YSPDX W " No diagnosis on file" Q
13 S L=$O(^ICD9("BA",+YSPDX(3),0)),L7=$S(YSPDX(4)["ICD":"i",1:"d")
14 I L'>0 W " ERROR" Q
15GRP ;
16 S ICDDX(1)=L,ICDPRC="" D ^ICDDRG S YSDRG=ICDDRG Q
17OA ;
18 S YSINDT=$P(^YSG("INP",YSN,0),U,3) Q:YSINDT'?7N.E S VAINDT=YSINDT D INP^VADPT S J1=VAIN(10)
19KINP ;
20 K YSDPT,YSINDT,YS1,ICDDMS,ICDEXP,ICDTRS,ICDDRG,ICDDX,ICDPRC,L,L7 Q
21 Q
Note: See TracBrowser for help on using the repository browser.