source: VWGUIRegistration/trunk/VWREGITU.m

Last change on this file was 1806, checked in by Jim B., 22 months ago
File size: 6.5 KB
Line 
1VWREGITU        ;Portland, OR/jeb et al World Vista Registration Utilities
2        ;2.0;;**LOCAL**;;2015;Build 4;;c2014
3        ;*****************************************************************
4        ;* Licensed under GNU 2.0 or greater - see license.txt file      *
5        ;* Program/application is for the management of input templates  *
6        ;* owned by the user (DUZ).                                      *
7        ;* REMINDER: All template fields pertain only to the Patient File*
8        ;*  (#2)!                                                        *
9        ;*****************************************************************
10        ;No Fall thru - jeb
11        Q
12        ;
13DFNID() ;Set NAME(IEN),TAB,DOB(AGE),TAB,HRN,TAB,PHONE#
14        N DFNID,NAME,X,Y,DOB,HRN,PHONE
15        I 'DFN Q ""
16        S NAME=$P(^DPT(DFN,0),"^")
17        S Y=$$OUTPUT^VWTIME(DFN) X ^DD("DD") S DOB=Y
18        S HRN=$G(^DPT(DFN,540001.1))
19        S PHONE="Phone: "_$P(^DPT(DFN,.13),"^")
20        S DFNID=NAME_$C(9)_DOB_$C(9)_$S($L(HRN):"HRN: "_HRN_$C(9),1:"")_PHONE
21        Q DFNID
22        ;
23HELP(XDIC,XFIELD)       ;
24        N N
25        K FHELP
26        S FHELP=$G(^DD(XDIC,XFIELD,3))
27        G:'$L(FHELP) HELPX
28        S FHELP=FHELP_$S($E($L(FHELP))=".":" ",1:". ")
29        I XFIELD'=27.02,$D(^DD(XDIC,XFIELD,21)) S N=0 F  S N=$O(^DD(XDIC,XFIELD,21,N)) Q:'+N  S FHELP=FHELP_^(N,0)_" "
30        S FHELP=$TR(FHELP,"'","`")
31HELPX     Q FHELP
32        ;
33M(RESULT,XMF)   ;
34        ; **********************************************
35        ; * XMF_____PARENT FIELD^DFN^TEMPLATE NAME(IEN)*
36        ; **********************************************
37        ;
38        ;W "  ;Intentional break
39        K RESULT,AR,TEMPLATE
40        N XMFD,SUBD,SUBD3,SUBD4,SUBD5,F2,F3,F4,F5,DFN,N,X,SUBF,XT,FHELP
41        S TNUM=+$P(XMF,"(",2)  ;Template IEN, if any
42        S DFN=+$P(XMF,"^",2)   ;Client IEN, if any
43        S XMF=+XMF  ;Parent field
44        I '+$P(^DD(2,XMF,0),"^",2) S RESULT(0)=-1  ;Not a parent, eh?!
45        S XMFD=+$P(^(0),"^",2)
46        S F=0 F  S F=$O(^DD(XMFD,F)) Q:'+F  S RESULT($$INR)=$P(^(F,0),"^")_"^"_XMFD_";"_F_"^^"_$$HELP(XMFD,F)_"^"_$P(^(0),"^",3) D:+$P(^(0),"^",2)
47        . S SUBD=+$P(^(0),"^",2)
48        . S F2=0 F  S F2=$O(^DD(SUBD,F2)) Q:'+F2  S RESULT($$INR)=$P(^(F2,0),"^")_"^"_SUBD_";"_F2_"^^"_$$HELP(SUBD,F2)_"^"_$P(^(0),"^",3) D:+$P(^DD(SUBD,F2,0),"^",2)
49        .. S SUBD3=+$P(^(0),"^",2)
50        .. S F3=0 F  S F3=$O(^DD(SUBD3,F3)) Q:'+F3  S RESULT($$INR)=$P(^(F3,0),"^")_"^"_SUBD3_";"_F3_"^^"_$$HELP(SUBD3,F3)_"^"_$P(^(0),"^",3) D:+$P(^DD(SUBD3,F3,0),"^",2)
51        ... S SUBD4=+$P(^DD(SUBD3,F3,0),"^",2)
52        ... S F4=0 F  S F4=$O(^DD(SUBD4,F4)) Q:'+F4  S RESULT($$INR)=$P(^(F4,0),"^")_"^"_SUBD4_";"_F4_"^^"_$$HELP(SUBD4,F4)_"^"_$P(^(0),"^",3) D:+$P(^DD(SUBD4,F2,0),"^",2)
53        .... S SUBD5=+$P(^(0),"^",2)
54        .... S F5=0 F  S F5=$O(^DD(SUBD5,F5)) Q:'+F5  S RESULT($$INR)=$P(^(F5,0),"^")_"^"_SUBD5_";"_F5_"^^"_$$HELP(SUBD5,F5)_"^"_$P(^(0),"^",3)
55        ;Clean up of parents IN multiple fields
56        M AR=RESULT K RESULT N DD,F
57        S N=0 F  S N=$O(AR(N)) Q:'+N  D
58        . S DD=+$P($P(AR(N),"^",2),";")  ;Is this a sub DD ?
59        . S F=+$P(AR(N),";",2)
60        . I +$P(^DD(DD,F,0),"^",2) K AR(N)
61        ;Clean up fields not in template
62        M TEMPLATE=^DIE(TNUM,"DR")
63        S X=$Q(@"TEMPLATE") K @X  ;Remove top, non-multiple subscript
64        S X="AR" F  S X=$Q(@X) Q:X=""  D
65        . S SUBD=+$P($P(@X,"^",2),";")
66        . S SUBF=+$P(@X,";",2)
67        . F I=1:1:20 I $D(TEMPLATE(I,SUBD)) D
68        .. Q:TEMPLATE(I,SUBD)[SUBF
69        .. K @X
70        S N=0 F  S N=$O(AR(N)) Q:'+N  S RESULT($$INR)=AR(N)
71        K AR,TEMPLATE
72        Q
73        ;
74DISV(RESULT,DFN)        ;Set the Disv GLOBAL
75        K RESULT
76        I '$L(DFN) S RESULT=-1 Q
77        S ^DISV(DUZ,"^DPT(")=+$P(DFN,"(",2),RESULT=1
78        Q
79        ;
80SR(FNAME,FNUM,FVALUE,FHELP,FSETPNTR,FMISC)      ;Set values into RESULT()
81        ;********************************************************
82        ;* FNAME________Field Name                              *
83        ;* FNUM_________Field Number                            *
84        ;* FVALUE_______Data from existing client/patient       *
85        ;* FHELP________Help text from field                    *
86        ;* FSETPNTR_____Set of codes or Pointer reference       *
87        ;* FMISC________Locally described designator (not used) *
88        ;********************************************************
89        S RESULT($$INR)=FNAME_"^"_FNUM_"^"_FVALUE_"^"_FHELP_"^"_FSETPNTR_"^"_FMISC
90        Q
91        ;       
92INR()   ;Specific incrementer for RESULT array
93        Q $O(RESULT(" "),-1)+1
94        ;
95ZPC(RESULT,ZIP) ;Get zip,county/area/region,state/province,preferred city
96        K RESULT N STP,CNTP,COUNTY,XZIP
97        S XZIP=ZIP S RESULT(0)="No return" Q:'$L(XZIP)
98        D POSTAL^XIPUTIL(XZIP,.ZIPDATA)
99        I $D(ZIPDATA("ERROR")) Q  ;Can't be found
100        S COUNTY=$G(ZIPDATA("COUNTY"))
101        S STP=$G(ZIPDATA("STATE POINTER"))
102        I STP,$L(COUNTY) S CNTP=$O(^DIC(5,STP,1,"B",COUNTY,0))
103        K RESULT(0)
104        S RESULT($$INR)=ZIPDATA("STATE")_"("_STP_")"
105        S RESULT($$INR)=ZIPDATA("COUNTY")_"("_CNTP_")"
106        S RESULT($$INR)=ZIPDATA("CITY")
107        S RESULT($$INR)=ZIPDATA("FIPS CODE")
108        K ZIPDATA
109        Q
110        ;
111SPI(RESULT,DFN) ;Simple patient inquiry display
112        S LINE="----------"
113        S DIC="^DPT(",DA=DFN,DIQ(0)="E",DIQ="AR"
114        S DR=".01:.05;.111:.115;.1171:.1173;.117;.363"
115        D EN^DIQ1
116        S CITY=$G(AR(2,DFN,.114,"E"))
117        S STIEN="",STATE=$G(AR(2,DFN,.115,"E")) S:$L(STATE) STIEN=$O(^DIC(5,"B",STATE,0))
118        S XAGE=$G(AR(2,DFN,.033,"E"))
119        S XAGE=$S(+XAGE:XAGE_" y/o",1:"")
120        ;;GET HRN
121HRN     S HRN="",N=$O(^AUPNPAT(DFN,41,0))
122        S HRN=$S('N:HRN,1:$P($G(^AUPNPAT(DFN,41,N,0)),"^",2))
123        S RESULT($$INR)=AR(2,DFN,.01,"E")_"  "_AR(2,DFN,.363,"E")_" HRN: "_HRN
124        S RESULT($$INR)="DOB: "_AR(2,DFN,.03,"E")_"  ("_XAGE_" "_AR(2,DFN,.02,"E")_")"
125        S RESULT($$INR)="ADDRESS"_LINE_LINE
126        S RESULT($$INR)=$G(AR(2,DFN,.111,"E"))_" "_$G(AR(2,DFN,.112,"E"))
127        S RESULT($$INR)=$G(AR(2,DFN,.114,"E"))_", "_$G(AR(2,DFN,.115,"E"))_"  "_$S($L($G(AR(2,DFN,.1172,"E"))):AR(2,DFN,.1172,"E"),1:$G(AR(2,DFN,.1112,"E")))
128        S RESULT($$INR)="Walk-ins"_LINE_LINE
129        S RESULT($$INR)="Appointments"_LINE_LINE
130        S RESULT($$INR)="Admissions"_LINE_LINE
131        Q
132        ;
133CONTROL()             ;Check for CONTROL status
134               N X S X=$O(^DIC(19,"B","VW REG IT CONTROL",0))
135               I 'X Q 0  ;Ain't no option there
136               Q $S($D(^VA(200,DUZ,203,"B",X)):1,1:0)
137               ;
138MISC(RESULT,VWDD)       ;Get simple value from VWDD ID
139        ;***************************************************
140        ;* VWDD___________________(sub)-Dictionary number  *
141        ;* Multiple delimiter_____;(Semicolon)             *
142        ;***************************************************
143        ;
144        I '$L(VWDD) S RESULT(0)="No value to evaluate" Q
145        K RESULT
146        N XDD,XDDLOC,N,X
147        G MISCSD:$G(^DD(VWDD,0,"UP"))
148        S CALLER=$S($P(VWDD,"^",2)="INS":1,1:0)
149        S VWDD=$P(VWDD,"^")
150        F I=1:1:$L(VWDD,";") S XDD=+$P(VWDD,";",I) S RESULT($$INR)="["_$P(^DIC(XDD,0),"^")_"]" D MISC1
151        I CALLER S RESULT($$INR)="[GUARANTOR]" D
152        . S X=$P(^DD(2.312,16,0),"^",3)
153        . F I=1:1:$L(X,";") S Y=$P(X,";",I),RESULT($$INR)=$P(Y,":",2)_"("_$P(Y,":")_")"
154        Q
155        ;
156MISC1   S XDDLOC=$G(^DIC(XDD,0,"GL")) D:$L(XDDLOC)
157        . S N=0 F  S N=$O(@(XDDLOC_N_")")) Q:'+N  D
158        .. I XDDLOC["779.004" S XCNAME=$P(@(XDDLOC_N_",0)"),"^")_" "_$P(^(0),"^",2)_" "_+$G(^("SDS"))_"("_N_")",RESULT($$INR)=XCNAME Q
159        .. S X=$P(@(XDDLOC_N_",0)"),"^")_"("_N_")",RESULT($$INR)=X
160MX      Q
161        ;
162MISCSD  ;Sub-dictionary
163        W ^("UP")
164        Q
165        ;
166       
Note: See TracBrowser for help on using the repository browser.