source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFUTL1.m@ 1726

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

initial load of FOIAVistA 6/30/08 version
File size: 6.4 KB
Line 
1IBDFUTL1 ;ALB/MAF - Maintenance Utility cont. - 4 20 95
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**32,23,51**;APR 24, 1997
3 ;
4 ;
5SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
6 ; S := string
7 ; V := destination
8 ; X := @ col X
9 ; L := # of chars
10 ;
11 Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
12 ;
13 ;
14SETARR ; -- Set up Listman array
15 S IBDCNT1=IBDCNT1+1
16 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
17 S X=""
18 S IBDFVAL=$J(IBDCNT1_")",5)
19 S X=$$SETSTR^VALM1(IBDFVAL,X,1,5)
20 S IBDFVAL=IBDFX
21 S X=$$SETSTR^VALM1(IBDFVAL,X,7,8)
22 S IBDFVAL=$P(IBDFTMP,"^",3)
23 S X=$$SETSTR^VALM1(IBDFVAL,X,17,15)
24 S IBDFVAL=$P(^IBE(357.1,IBDFBLK,0),"^",1)
25 S X=$$SETSTR^VALM1(IBDFVAL,X,34,14)
26 S IBDFVAL=$P(^IBE(357,IBDFORM1,0),"^",1)
27 S X=$$SETSTR^VALM1(IBDFVAL,X,50,14)
28 I $D(VAUTC)!($D(VAUTG)) S IBDFVAL=$P(IBDFTMP,"^",6) S X=$$SETSTR^VALM1(IBDFVAL,X,66,14)
29 ;
30 ;
31TMP ; -- Set up TMP Array
32 S ^TMP("CPT",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("CPT",$J,"IDX",VALMCNT,IBDCNT1)=""
33 S ^TMP("CPTIDX",$J,IBDCNT1)=VALMCNT_"^"_IBDFX_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",5)_"^"_$P(IBDFTMP,"^",1)_"^"_$P(IBDFTMP,"^",2)
34 Q
35SETARR1 ; -- Set up Listman array
36 N IBDPRIM,IBDSELP
37 S IBDSELP=$P($G(IBDFTMP),"^",5)
38 Q:IBDSELP']""
39 S IBDPRIM=$P($G(^IBE(357.3,IBDSELP,0)),"^")
40 I IBDPRIM=IBDFX Q
41 ;S IBDCNT1=IBDCNT1+1
42 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
43 S X=""
44 S IBDFVAL="Primary Diagnosis: "_IBDPRIM
45 S X=$$SETSTR^VALM1(IBDFVAL,X,17,40)
46 ;
47 ;
48TMP1 ; -- Set up TMP Array
49 S ^TMP("CPT",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("CPT",$J,"IDX",VALMCNT,IBDCNT1)=""
50 Q
51 ;
52 ;
53SET ; -- Loop thru to see if codes are valid
54 F IBDFBLK=0:0 S IBDFBLK=$O(^IBE(357.1,"C",IBDFORM,IBDFBLK)) Q:'IBDFBLK D
55 .F IBDFLST=0:0 S IBDFLST=$O(^IBE(357.2,"C",IBDFBLK,IBDFLST)) Q:'IBDFLST S IBDFNODE=$G(^IBE(357.2,IBDFLST,0)) I $P(IBDFNODE,"^",11)=IBDFINT D
56 ..F IBDFSEL=0:0 S IBDFSEL=$O(^IBE(357.3,"C",IBDFLST,IBDFSEL)) Q:'IBDFSEL S IBDFX=$G(^IBE(357.3,IBDFSEL,0)) I $P(IBDFX,"^",2)']"" D
57 ...S IBDFX1=$P(IBDFX,"^",1),IBDFX2=$P($G(^IBE(357.3,IBDFSEL,2)),"^",3),IBDFX3=$P($G(^IBE(357.3,IBDFSEL,2)),"^",4)
58 ...F IBI=IBDFX1,IBDFX2,IBDFX3 I IBI]"" D
59 ....I IBDFACT=1 D
60 .....S (X,IBDFX)=IBI
61 .....X $G(^IBE(357.6,IBDFINT,11))
62 .....Q:'$D(X)
63 .....;;----change to api cpt;dhh
64 .....I $G(IBDFCODE)="CPT " N IBY,XX D
65 ......S XX=$$CPT^ICPTCOD(X)
66 ......;;S IBY=$S(+XX=-1:"",1:$P(XX,"^",3))
67 ......S IBY=$S($P(XX,U,7)'=1:"",1:$P(XX,"^",3))
68 .....;;I $G(IBDFCODE)="ICD-9 " N IBY S IBY=$P($G(^ICD9(X,0)),"^",3)
69 .....I $G(IBDFCODE)="ICD-9 " N IBY S IBY=$P($$ICDDX^ICDCODE(X),U,4)
70 .....I $G(IBDFCODE)="Type of Visit " N IBY S IBY=$P($G(^IBE(357.69,X,0)),"^",2)
71 .....Q:'$D(VAUTJ(X))
72 .....S ^TMP("UTIL",$J,IBDFNAME,IBDFX,$P(^IBE(357,IBDFORM,0),"^",1),$P(^IBE(357.1,IBDFBLK,0),"^",1),IBDFSEL)=IBDFORM_"^"_IBDFBLK_"^"_$S(IBY]"":IBY,1:"INVALID")_"^"_IBDFLST_"^"_IBDFSEL_"^"_$S($D(VAUTC):IBDFNAME,$D(VAUTG):IBDFCLNM,1:"")
73 ....I IBDFACT=2 D
74 .....S (X,IBDFX)=IBI
75 .....X $G(^IBE(357.6,IBDFINT,11))
76 .....I '$D(X) S ^TMP("UTIL",$J,IBDFNAME,IBDFX,$P(^IBE(357,IBDFORM,0),"^",1),$P(^IBE(357.1,IBDFBLK,0),"^",1),IBDFSEL)=IBDFORM_"^"_IBDFBLK_"^"_$S(Y]"":Y,1:"INVALID")_"^"_IBDFLST_"^"_IBDFSEL_"^"_$S($D(VAUTC):IBDFNAME,$D(VAUTG):IBDFCLNM,1:"")
77 Q
78 ;
79 ;
80 ; -- Set up alphabetical listing
81SET1 S (IBDFORM1,IBDFBLK,IBDFLG,IBDFX,IBDFNAME,IBDORM,IBDBLK)=0
82 F IBDFNM=0:0 S IBDFNAME=$O(^TMP("UTIL",$J,IBDFNAME)) Q:IBDFNAME']"" S IBDFX="" F S IBDFX=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX)) D:(IBDFX="")&($D(VAUTF)) CLINICS^IBDFUTL2 Q:IBDFX="" D
83 .F IBDFRM=0:0 S IBDORM=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM)) Q:IBDORM']"" F IBDFBK=0:0 S IBDBLK=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM,IBDBLK)) Q:IBDBLK']"" D
84 ..F S IBDFSEL=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL)) Q:IBDFSEL']"" D
85 ...S IBDFTMP=^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL),IBDFORM1=$P(IBDFTMP,"^",1),IBDFBLK=$P(IBDFTMP,"^",2) D:'$D(IBDF(IBDFNAME)) HEADER^IBDFUTL2 D SETARR D:IBDBLK="DIAGNOSIS" SETARR1
86 Q
87 ;
88 ;
89CLIN1 ; -- Sort Display by clinic
90 N IBDFBLK,IBDFLST,IBDFORM,VAUTF
91 I VAUTC=1 F X=0:0 S X=$O(^SC(X)) Q:'X I $D(^SC(X,0)) S ^TMP("CLN",$J,X)=$P(^SC(X,0),"^",1)
92 I VAUTC=0 K ^TMP("CLN",$J) F IBDFCLIN=0:0 S IBDFCLIN=$O(VAUTC(IBDFCLIN)) Q:'IBDFCLIN S X=$G(VAUTC(IBDFCLIN)) S ^TMP("CLN",$J,IBDFCLIN)=X
93 I '$D(IBDFNCNG) K ^TMP("CLN1",$J)
94 F IBDFCLIN=0:0 S IBDFCLIN=$O(^TMP("CLN",$J,IBDFCLIN)) Q:'IBDFCLIN S X=$G(^TMP("CLN",$J,IBDFCLIN)) S ^TMP("CLN1",$J,X)=IBDFCLIN
95 S IBDCLNM=0 F IBDCLN=0:0 S IBDCLNM=$O(^TMP("CLN1",$J,IBDCLNM)) Q:IBDCLNM']"" S IBDFCLIN=^TMP("CLN1",$J,IBDCLNM) S IBDFCIFN=$O(^SD(409.95,"B",IBDFCLIN,0)) S IBDCNODE=$G(^SD(409.95,+IBDFCIFN,0)),IBDFNAME=IBDCLNM I $D(IBDCNODE) D
96 .F IBDFN=2:1:9 S IBDFORM=$P(IBDCNODE,"^",IBDFN) I IBDFORM D SET
97 D SET1 Q
98 ;
99 ;
100FORM1 ; -- Sort Display by form
101 N IBDFBLK,IBDFLST,IBDFORM
102 I VAUTF=1 S IBDFRNM=0 F IBDFRM=0:0 S IBDFRNM=$O(^IBE(357,"B",IBDFRNM)) Q:IBDFRNM']"" F IBDFORM=0:0 S IBDFORM=$O(^IBE(357,"B",IBDFRNM,IBDFORM)) Q:'IBDFORM S IBDFNAME=IBDFRNM D SET
103 I '$D(IBDFNCNG) K ^TMP("FRM1",$J)
104 I VAUTF=0 F IBDFORM=0:0 S IBDFORM=$O(VAUTF(IBDFORM)) Q:'IBDFORM S X=$G(VAUTF(IBDFORM)) S ^TMP("FRM1",$J,X)=IBDFORM
105 I VAUTF=0 S IBDFRNM=0 F IBDFRM=0:0 S IBDFRNM=$O(^TMP("FRM1",$J,IBDFRNM)) Q:IBDFRNM']"" S IBDFORM=^TMP("FRM1",$J,IBDFRNM),IBDFNAME=IBDFRNM D SET
106 D SET1
107 Q
108 ;
109 ;
110GROUP1 ; -- Sort Display by clinic group
111 N IBDFBLK,IBDFLST,IBDFORM,VAUTF
112 I VAUTG=1 S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^IBD(357.99,"B",IBDFGNM)) Q:IBDFGNM']"" F IBDFGIFN=0:0 S IBDFGIFN=$O(^IBD(357.99,"B",IBDFGNM,IBDFGIFN)) Q:'IBDFGIFN S ^TMP("GRP1",$J,IBDFGNM)=IBDFGIFN
113 I VAUTG=0,'$D(IBDFNCNG) K ^TMP("GRP1",$J)
114 I VAUTG=0 F IBDFGIFN=0:0 S IBDFGIFN=$O(VAUTG(IBDFGIFN)) Q:'IBDFGIFN S ^TMP("GRP1",$J,VAUTG(IBDFGIFN))=IBDFGIFN
115 S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^TMP("GRP1",$J,IBDFGNM)) Q:IBDFGNM']"" S IBDFGIFN=^TMP("GRP1",$J,IBDFGNM) D
116 .S IEN=0 F S IEN=$O(^IBD(357.99,IBDFGIFN,10,IEN)) Q:'IEN S IBCLN=+$G(^IBD(357.99,IBDFGIFN,10,IEN,0)) S:$D(^SC(IBCLN,0)) ^TMP("IBDF",$J,"C",IBDFGNM,$P(^SC(IBCLN,0),"^",1))=IBCLN
117 .S IEN=0 F S IEN=$O(^IBD(357.99,IBDFGIFN,11,IEN)) Q:'IEN S IBDIV=+$G(^IBD(357.99,IBDFGIFN,11,IEN,0)) S:IBDIV ^TMP("IBDF",$J,"D",IBDFGNM,IBDIV)=""
118 D:$D(^TMP("IBDF",$J,"D")) ENDV^IBDFUTL2
119 S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^TMP("IBDF",$J,"C",IBDFGNM)) Q:IBDFGNM']"" S IBDFCLNM=0 F IBDFCLN=0:0 S IBDFCLNM=$O(^TMP("IBDF",$J,"C",IBDFGNM,IBDFCLNM)) Q:IBDFCLNM']"" D
120 .S IBDFCLIN=$G(^TMP("IBDF",$J,"C",IBDFGNM,IBDFCLNM)),IBDFCIFN=$O(^SD(409.95,"B",IBDFCLIN,0)) S IBDCNODE=$G(^SD(409.95,+IBDFCIFN,0)) I $D(IBDCNODE) S IBDFNAME=IBDFGNM F IBDFN=2:1:9 S IBDFORM=$P(IBDCNODE,"^",IBDFN) I IBDFORM D SET
121 D SET1 Q
Note: See TracBrowser for help on using the repository browser.