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

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

initial load of WorldVistAEHR

File size: 4.7 KB
Line 
1DGPTSCAN ;ALB/MTC - SPECIAL ACTION SCAN PROCESS ; 1 MAR 91
2 ;;5.3;Registration;**29,64,114,189,729**;Aug 13, 1993;Build 59
3 ;;MAS 5.1
4CHK501 ;--
5 D INIT G ENQ:DGOUT
6 G ENQ:'$D(^DGPT(DGPTF,"M",+DGMOV,0)) S DGREC=^(0)
7 F DGI=5:1:9 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD9(")=""
8 S DGHOLD=$S($D(^DGPT(DGPTF,"M",+DGMOV,300)):^(300),1:"")
9 D SCAN
10 I '$D(DGBPC),DGHOLD']"" G CHK5Q
11 S DIE="^DGPT(",DA=DGPTF,DR="[DGPT 501 CLEANUP]"
12 D ^DIE
13 ;;
14 ;;ADDED FOR GAF ENHANCEMENT 6/2/98
15 ;;Gathers GAF Score, GAF Date, GAF Provider and sends to
16 ;;Mental Health package
17 N DGGAFSC,DGGAFDT,DGGAFPR,DGDFN
18 S DGGAFSC=$P(DGHOLD,"^",6),DGDFN=$P(^DGPT(DGPTF,0),"^")
19 S DGGAFDT=$P(^DGPT(DGPTF,0),"^",2)\1
20 S DGGAFPR=$P($G(^DGPT(DGPTF,"M",+DGMOV,"P")),"^",5) ;Provider
21 D UPD^YSGAF(DGDFN,DGGAFSC,DGGAFDT,DGGAFPR,"I")
22 ;;END GAF ENHANCEMENTS
23 ;;
24CHK5Q K DA,DR,DGHOLD,DGBPC,DGPTIT,DIE,DGREC,DGI,DGSCDT,DGSTART,DGTREC,DGOUT
25 Q
26 ;
27CHK601 ;--
28 D INIT G ENQ:DGOUT
29 G ENQ:'$D(^DGPT(DGPTF,"P",+P(DGZP,1),0)) S DGREC=^(0)
30 F DGI=5:1:9 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD0(")=""
31 S DGHOLD=DGREC
32 D SCAN
33 I '$D(DGBPC(8)),$P(DGHOLD,U,4)']"" G CHK6Q
34 S DIE="^DGPT(",DA=DGPTF,DR="[DGPT 601 CLEANUP]"
35 D ^DIE
36CHK6Q K DA,DR,DGHOLD,DGBPC,DGPTIT,DIE,DGREC,DGI,DGOUT
37 Q
38CHK401 ;--
39 D INIT G ENQ:DGOUT
40 G ENQ:'$D(^DGPT(DGPTF,"S",+DGSUR,0)) S DGREC=^(0)
41 F DGI=8:1:12 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD0(")=""
42 S DGHOLD=$S($D(^DGPT(DGPTF,"S",+DGSUR,300)):^(300),1:"")
43 D SCAN
44 I '$D(DGBPC),DGHOLD']"" G CHK4Q
45 S DIE="^DGPT(",DA=DGPTF,DR="[DGPT 401 CLEANUP]"
46 D ^DIE
47CHK4Q K DA,DR,DGHOLD,DGBPC,DGPTIT,DIE,DGREC,DGI,DGSCDT,DGSTART,DGTREC,DGOUT
48 Q
49 ;
50CHK701 ;-- will get data from flagchk then stuff into 701 (300 node)
51 G CHK7Q:'$D(^DGPT(DGPTF,70)) S DGREC=^(70)
52 F DGI=10,16:1:24 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD9(")=""
53 D DC,SCAN,ANYPSY,FLAGCHK
54 S DGREC=$S($D(^DGPT(DGPTF,300)):^(300),1:""),DR="",DA=DGPTF,DIE="^DGPT("
55 D GETNUM
56 F DGII=2:1:DGFNUM S DR=DR_$S($P(DG701,U,DGII)]""&($P(DG701,U,DGII)'=$P(DGREC,U,DGII)):"300.0"_DGII_"////"_$P(DG701,U,DGII)_";",'$D(DGBPC(DGII))&($P(DGREC,U,DGII)]"")&($P(DG701,U,DGII)']""):"300.0"_DGII_"////@;",1:"")
57CHK7J I DR]"" D ^DIE
58CHK7Q ;
59 K DGII,DA,DR,DIE,DG701,DGI,DGT,DGREC,DGFNUM,DGSCDT,DGSTART,DGTREC,DGOUT
60 Q
61FLAGCHK ;-- build 701 from 501 responses, kill flags if necessary
62 S DG701="",DGOUT=0
63 F DGI=0:0 S DGI=$O(^DGPT(DGPTF,"M","AM",DGI)) Q:DGI'>0 F DGJ=0:0 S DGJ=$O(^DGPT(DGPTF,"M","AM",DGI,DGJ)) Q:DGJ'>0 I $D(^DGPT(DGPTF,"M",DGJ,300)) S DGHOLD=^(300) D FL1
64 S DGNDIS=$S('$D(^DGPT(DGPTF,70)):0,1:+^(70))
65 I DGNDIS'>0,$D(^DGPT(DGPTF,"M",1,300)) S DGHOLD=^(300) D FL1
66FLAGQ K DGI,DGNDIS
67 Q
68FL1 ;
69 D GETNUM
70 F DGII=2:1:DGFNUM I $P(DGHOLD,U,DGII)]"",$P(DG701,U,DGII)']"" S $P(DG701,U,DGII)=$P(DGHOLD,U,DGII) K DGBPC(DGII)
71FL1Q K DGII,DGHOLD,DGK,DGFNUM
72 Q
73 ;
74SCAN ;-- process DGPTIT array
75 K DGBPC
76 D ISPSY
77 G:'$D(DGPTIT) SCANQ
78 D DC ;return discharge date or current date in DGSCDT
79 S DGI="" F DGJ=0:0 S DGI=$O(DGPTIT(DGI)) Q:DGI="" F DGK=0:0 S DGK=$O(^DIC(45.89,"ASPL",DGI,DGK)) Q:'DGK D S1
80SCANQ ;
81 K DGSPEC,DGI,DGJ,DGK
82 Q
83 ;
84S1 ;-- check inactive dates, set flag array
85 G S1Q:'$D(^DIC(45.89,DGK,0)) S X=^(0)
86 I $P(X,U,3)]"",$D(DGSCDT) G S1Q:DGSCDT>$P(X,U,3)
87 S Y=+X
88 G S1Q:'$D(^DIC(45.88,Y,0)) S X=^(0)
89 I $P(X,U,3)]"",$D(DGSCDT) G S1Q:DGSCDT>$P(X,U,3)
90 I $P(X,U,2)]"" S X=$P(X,U,2) F DGII=1:1 S Y=$P(X,",",DGII) Q:'Y D FLGFIL
91S1Q ;
92 K X,Y,DGII
93 Q
94 ;
95DC ;-- find discharge date
96 S DGSCDT=$S('$D(^DGPT(PTF,70)):DT,^(70):+^(70),1:DT)
97 Q
98 ;
99ENQ ;
100 K DG701,DGSTART,DGI,DGOUT,DGREC,DGBPC,DGPTIT,DGTREC,DGSCDT
101 Q
102 ;
103GETNUM ;-- returns the number of additional questions/flags
104 S DGFNUM=7
105 Q
106 ;
107INIT ;-- init routine
108 S DGOUT=0,(DGTREC,DGHOLD)=""
109 ;-- DGSTART should be set to 2910930 for national release
110 S DGSTART=2910930
111 D DC
112 D LO^DGUTL,HOME^%ZIS
113 K DGPTIT
114INITQ ;
115 Q
116 ;
117ANYPSY ;-- will go through all movements check for PSYCH specialty
118 N DGMOV
119 K DGPSY
120 I '$D(^DGPT(DGPTF,"M")) G ANYQ
121 F DGMOV=0:0 S DGMOV=$O(^DGPT(DGPTF,"M",DGMOV)) Q:'DGMOV D ISPSY I $D(DGSPEC) S DGPSY=""
122 I '$D(DGPSY) K DGBPC(5),DGBPC(6),DGBPC(7)
123ANYQ ;
124 K DGSPEC
125 Q
126ISPSY ;-- check if losing specialty is in psych range set flag.
127 ;-- if psych then $D(DGSPEC)
128 K DGSPEC
129 I '$D(DGMOV) S DGSPEC="" G ISPSYQ
130 I $D(DGMOV) S DGSPEC=$P(^DGPT(DGPTF,"M",DGMOV,0),U,2) I '$P($G(^DIC(42.4,+DGSPEC,0)),U,4) K DGSPEC
131ISPSYQ Q
132 ;
133FLGFIL ;-- fill DGBPC with correct flag.
134 I '$D(DGSPEC),Y>4,Y<8 G FLGFILQ
135 S DGBPC(Y)=""
136FLGFILQ ;
137 Q
138 ;
139ANYSC(PTF) ;-- will go through all movements check for sc treatment
140 ; INPUT - ptf record ien to check
141 ; OUTPUT- 1 sc treatment, 0 no sc treatment
142 N DGMOV,RESULT
143 S RESULT=0
144 I '$D(^DGPT(PTF,"M")) G ANYSCQ
145 S DGMOV=0 F S DGMOV=$O(^DGPT(PTF,"M",DGMOV)) Q:'DGMOV I $P(^(DGMOV,0),U,18)=1 S RESULT=1 Q
146ANYSCQ ;
147 Q RESULT
148 ;
Note: See TracBrowser for help on using the repository browser.