source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGA4004.m@ 691

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

initial load of WorldVistAEHR
File size: 3.4 KB
RevLine 
[613]1DGA4004 ;ALB/MRL - AMIS 420 ACTUAL GENERATION OF REPORTS ;01 JAN 1988@2300
2 ;;5.3;Registration;**41**;Aug 13, 1993
3 ;S IOP=$S($D(ION):ION,1:IO)_";132" D ^%ZIS K IOP I IO=DGDEV W !!,"===> Collecting AMIS 401-420 Statistics..."
4 I IO=DGDEV W !!,"===> Collecting AMIS 401-420 Statistics..."
5 D DEL^DGA4003 K ^UTILITY($J,"DGSEG"),^("DGSEGP") D DIV^DGUTL
6 S DGDV=DGDIV F DFN=0:0 S DFN=$O(^UTILITY($J,"DGDIS",DFN)) Q:'DFN F DGREG=0:0 S DGREG=$O(^UTILITY($J,"DGDIS",DFN,DGREG)) Q:'DGREG S DGDATA=^(DGREG),DGDISLO=$P(DGDATA,"^",6) D REP
7 I $D(^UTILITY($J,"DGSEG")) W:IO=DGDEV !!,"===> Storing Data in 'AMIS SEGMENT' file..." G SAV^DGA4005
8 G QUIT^DGA4002
9REP S (DGSEG,DGSEGR)="" I $P(DGDATA,"^",17),$P(DGDATA,"^",17)<418 S DGSEG=$P(DGDATA,"^",17)
10 S X1=$S($D(^DIC(8,+$P(DGDATA,"^",13),0)):$P(^(0),"^",5),1:"") I X1'="Y" S DGSEG=420,DGSEGR="NV"
11 I 'DGSEG S DGXXXD=1,DGDATA1=DGDATA D SEG1
12 I 'DGDIV S I=$P(DGDATA,"^",4) D DV^DGA4001
13 S DGBLK="",DGX=$S($D(^DIC(37,+$P(DGDATA,"^",7),0)):^(0),1:""),DGX1=+$P(DGX,"^",9),DGBLK=$S(DGSEGR="NV":40,DGX']"":8,'DGX1:8,1:"") I DGBLK G GOTIT
14 I "^TRT^INE^LOW^"'[("^"_$E(DGX,1,3)_"^") S DGBLK=DGBLK_$P("10^8^6^7^8^2^3^4^5^9^8^8^38^8^39","^",DGX1)_"^" G GOTIT
15 S DGX2=+$P(DGDATA,"^",3),DGX2=$S(DGX2=1:1,DGX2=2:3,DGX2=5:2,1:4) I "^INE^"[("^"_$E(DGX,1,3)_"^") S DGX3=+$P(DGDATA,"^",11),DGBLK=DGBLK_(DGX3+10)_"^"_(DGX2+15)_"^"_$S(DGX1=2:20,1:21)_"^" G GOTIT
16 I "^TRT^"[("^"_$E(DGX,1,3)_"^") S DGBLK=DGBLK_(DGX2+21)_"^"_$S(DGX1=2:26,DGX1=14:27,DGX1=5:28,1:29)_"^" G GOTIT
17 S DGBLK=DGBLK_(DGX2+29)_"^"_$S(DGX1=2:34,DGX1=14:35,DGX1=5:36,1:37)_"^"
18GOTIT S DGBLK="1^"_DGBLK,DGN1="",DGN=$S($D(^UTILITY($J,"DGSEG",DGSEG,+DGDV)):^(+DGDV),1:"") F I=1:1 S J=$P(DGBLK,"^",I) Q:J="" S $P(DGN,"^",J)=$P(DGN,"^",J)+1 I J>1 S DGN1=DGN1_$S(J<10:"0"_J,1:J)_","
19 W:IO=DGDEV "." S ^UTILITY($J,"DGSEG",DGSEG,+DGDV)=DGN Q:'DGAL
20 S X=$S($D(^DPT(DFN,0)):^(0),1:""),X1=$S($P(X,"^",1)'="":$P(X,"^",1),1:"PATIENT #"_DFN),X2=$E($P(X1,",",1)_","_$E(X1,$F(X1,",")),1,15),$P(DGN1,"^",2)=$E($P(X,"^",9),6,9)_"^"_$S($D(^DIC(8,+$P(DGDATA,"^",13),0)):$P(^(0),"^",6),1:"UNKNOWN")
21 S $P(DGN1,"^",4)=$S($P(DGDATA,"^",3)=1:"Hosp Care",$P(DGDATA,"^",3)=2:"Dom Care",$P(DGDATA,"^",3)=3:"OP Medical",$P(DGDATA,"^",3)=4:"OP Dental",$P(DGDATA,"^",3)=5:"NHCU Care",1:"Unknown"),$P(DGN1,"^",5)=$E(DGX,1,30)
22 S ^UTILITY($J,"DGSEGP",+DGDV,DGSEG,X2,+DGDATA)=DGN1 Q
23SEG ;Determine Segment to count patient in
24 S DGSEG="",DGDATA1=$S($D(^DPT(DFN,"DIS",DFN1,0)):^(0),1:"") Q:'DGDATA1
25SEG1 S DGSEGR="" G SEG2:'$P(DGDATA1,"^",15) S X=$P(DGDATA1,"^",16) I X']""!(X#10) S DGSEG=412 G SEGQ
26 I 'X S DGSEG=411 G SEGQ
27 S X=X/10,DGSEG=$P("410^409^408^407^406^405^404^403^402^401","^",X) G SEGQ
28SEG2 S X1=$S($D(^DIC(8,+$P(DGDATA1,"^",13),0)):$P(^(0),"^",5),1:"") I X1'="Y" S DGSEGR="NV",DGSEG=420 G SEGQ
29 S X=$S($D(^DIC(8,+$P(DGDATA1,"^",13),0)):$P(^(0),"^",9),1:"") I X']"" G CAT:DGXXXD,SEGQ
30 I X=18 S DGSEG=413 G SEGQ
31 S X1=$S($D(^DPT(DFN,.321)):^(.321),1:"") I $P(X1,"^",2)="Y"!($P(X1,"^",3)="Y") S DGSEG=414 G SEGQ
32 I X=16!(X=17) S DGSEG=415 G SEGQ
33 I X=4 S DGSEG=416 G SEGQ
34 I $P($G(^DPT(DFN,.38)),U) S DGSEG=417 G SEGQ
35 G SEGQ:'DGXXXD
36CAT ;Determine Category for others
37 I '$D(^DGMT(408.31,"AD",1,DFN)) S DGSEGR="NM",DGSEG=418 G SEGQ
38 S DGLSTMN=$P($$LST^DGMTU(DFN,+DGDISLO),U,4)
39 I DGLSTMN']"" S DGSEGR="NT",DGSEG=418 G SEGQ
40 S DGSEG=$S(DGLSTMN="B":419,"CP"[DGLSTMN:420,1:418),DGSEGR=DGLSTMN
41SEGQ K DGZ,DGZ1,DGZ2,X,X1,DGDATA1,DGLSTMN I 'DGXXXD K DGSEGR Q
42 I $D(DGSEG),$D(^DPT(DFN,"DIS",DGREG,0)) S $P(^(0),"^",17)=DGSEG
43 Q
Note: See TracBrowser for help on using the repository browser.