| 1 | VWREGIT ;Portland,OR/Jim Bell, et al Patient Registration Utility August 2015
|
|---|
| 2 | ;;2.0;WORLD VISTA;**LOCAL**;;Build 2
|
|---|
| 3 | ;*******************************************************************
|
|---|
| 4 | ;* VW Registration is designed for patient specific fields as *
|
|---|
| 5 | ;* defined in Fileman Input Templates or ad hoc field selection. *
|
|---|
| 6 | ;* Copyright Martius/MMXV ad infinitum (GNU License: See GPLv3.txt)*
|
|---|
| 7 | ;*******************************************************************
|
|---|
| 8 | ;;NO FALL THROUGH - JEB
|
|---|
| 9 | Q
|
|---|
| 10 | ;
|
|---|
| 11 | TFM(XF) ;TemplateField Management
|
|---|
| 12 | ;***********************************************
|
|---|
| 13 | ;* Check primary field entries for "parentage" *
|
|---|
| 14 | ;* Add an "*" to gain all sub-fields of the *
|
|---|
| 15 | ;* parent *
|
|---|
| 16 | ;* REMEMBER: All fields pertain to file 2 only *
|
|---|
| 17 | ;***********************************************
|
|---|
| 18 | N I,N,FIELD
|
|---|
| 19 | K FARRAY
|
|---|
| 20 | I '$L(XF),'$G(TNUM) Q ""
|
|---|
| 21 | I '$L(XF),+$G(TNUM) S XF=^DIE(TNUM,"DR",1,2)
|
|---|
| 22 | F I=1:1:$L(XF,";") S:$L($P(XF,";",I)) FARRAY(I)=+$P(XF,";",I)
|
|---|
| 23 | S N=0 F I=1:1 S N=$O(FARRAY(N)) Q:'+N D
|
|---|
| 24 | . S FIELD=FARRAY(N)
|
|---|
| 25 | . I +$P(^DD(2,FIELD,0),"^",2) S FIELD=FIELD_"*",FMARRAY(FIELD)=$P(^(0),"^",4) K FARRAY(N)
|
|---|
| 26 | S XF="",N=0 F S N=$O(FARRAY(N)) Q:'+N S XF=XF_FARRAY(N)_";"
|
|---|
| 27 | Q XF
|
|---|
| 28 | ;
|
|---|
| 29 | CHECK() ;
|
|---|
| 30 | Q ""
|
|---|
| 31 | ;
|
|---|
| 32 | INR() Q $O(RESULT(" "),-1)+1
|
|---|
| 33 | ;
|
|---|
| 34 | EN(RESULT) ;Template name and ID labels
|
|---|
| 35 | ;W "
|
|---|
| 36 | ;Get the input template list
|
|---|
| 37 | ;housekeeping
|
|---|
| 38 | S DTIME=99999
|
|---|
| 39 | ;ZSY "chmod 777 "_$ZD_"regparam/*.txt" ;Moved to post-install
|
|---|
| 40 | ;end housekeeping
|
|---|
| 41 | ;
|
|---|
| 42 | K AR,RESULT
|
|---|
| 43 | N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO,DEFST,XTMP,X
|
|---|
| 44 | S RESULT(0)=1
|
|---|
| 45 | S DEFST="";
|
|---|
| 46 | ;S DEFTMP=$O(^DIE("B","FAU_EDU",0)) ;For Florida College only
|
|---|
| 47 | S RESULT(0)=$$CONTROL^VWREGITU()
|
|---|
| 48 | S RESULT(1)="-1^No templates found"
|
|---|
| 49 | S DEFST=$$GET^XPAR("ALL","VW REG DEFAULT STATE")
|
|---|
| 50 | S DEFTMP=$$GET^XPAR("ALL","VW REG RDNPT")
|
|---|
| 51 | S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
|
|---|
| 52 | I '$L(HD) K RESULT D Q
|
|---|
| 53 | . S RESULT($$INR)="-1^NO HOME DIRECTORY - refer to IT support, if necessary."
|
|---|
| 54 | . S RESULT($$INR)="No home directory has been supplied which indicates"
|
|---|
| 55 | . S RESULT($$INR)="the VWREG installation is incomplete. See the Help manual"
|
|---|
| 56 | . S RESULT($$INR)="for installation and Enter/Editing parameter values."
|
|---|
| 57 | . S RESULT($$INR)="Thank you,"
|
|---|
| 58 | . S RESULT($$INR)=" The Management."
|
|---|
| 59 | S FILE="regit.txt"
|
|---|
| 60 | S P4=1
|
|---|
| 61 | S P5=""
|
|---|
| 62 | S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
|
|---|
| 63 | D:+RESULT(0)
|
|---|
| 64 | . S $P(RESULT(0),"^",2)=$G(HD)
|
|---|
| 65 | . S $P(RESULT(0),"^",3)=$S(DEFST:$P(^DIC(5,DEFST,0),"^")_"("_DEFST_")",1:"")
|
|---|
| 66 | . S $P(RESULT(0),"^",4)=$S(+DEFTMP:$P(^DIE(DEFTMP,0),"^")_"("_DEFTMP_")",1:DEFTMP)
|
|---|
| 67 | . S $P(RESULT(0),"^",5)=DUZ
|
|---|
| 68 | I $O(AR(0)) S RESULT(1)="[TEMPLATES]"
|
|---|
| 69 | S N=0 F S N=$O(AR(N)) Q:'+N D
|
|---|
| 70 | . Q:$E(AR(N))="*"
|
|---|
| 71 | . Q:'+$P(AR(N),"(",2)
|
|---|
| 72 | . Q:$P($G(^DIE(+$P(AR(N),"(",2),0)),"^",4)'=2 ;must be pat file
|
|---|
| 73 | . S RESULT($$INR)=AR(N)
|
|---|
| 74 | S RESULT($$INR)="[ID]"
|
|---|
| 75 | ;S N=0 F S N=$O(^DIZ(64850003,N)) Q:'+N S RESULT($$INR)=$P(^(N,0),"^",2)_"("_$P(^(0),"^")_")"
|
|---|
| 76 | ;S N=0 F S N=$O(RESULT(N)) Q:'+N K:RESULT(N)="" RESULT(N)
|
|---|
| 77 | I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found"
|
|---|
| 78 | K AR
|
|---|
| 79 | Q
|
|---|
| 80 | ;
|
|---|
| 81 | NPT(RESULT,TNAME) ;
|
|---|
| 82 | ; *************************************************
|
|---|
| 83 | ; * Incoming: DFN^TEMPLATE NAME(IEN) *
|
|---|
| 84 | ; * Process : Get template fields plus any help *
|
|---|
| 85 | ; * If +TNAME (a DFN), get DFN data for *
|
|---|
| 86 | ; * the template fields (Put data in *
|
|---|
| 87 | ; * $P(RESULT(N),"^",3)) *
|
|---|
| 88 | ; * Return : RESULT(N), etc *
|
|---|
| 89 | ; *************************************************
|
|---|
| 90 | ;W " ;Intentional bust for debugging
|
|---|
| 91 | N N,TNUM,FIELDS,F,FNAME,FVALUE,FHELP,FPSC,FNUM
|
|---|
| 92 | S TNUM=+$P(TNAME,"(",2),DFN=+TNAME
|
|---|
| 93 | I 'TNUM S RESULT(0)="0^new patient Template not found" Q
|
|---|
| 94 | S TNAME=$P($P(TNAME,"^",2),"(")
|
|---|
| 95 | S TNAME=$TR(TNAME,"$&*","") ;Clean out TMENU chars
|
|---|
| 96 | I TNAME="GENERIC INS. FRM [WorldVistA]" G GIF
|
|---|
| 97 | S FIELDS=$G(^DIE(TNUM,"DR",1,2))
|
|---|
| 98 | I '$L(FIELDS) Q
|
|---|
| 99 | K RESULT S (FNUM,FCAP)=""
|
|---|
| 100 | F I=1:1:$L(FIELDS,";")-1 D
|
|---|
| 101 | . S F=$P(FIELDS,";",I)
|
|---|
| 102 | . Q:'$D(^DD(2,F)) ;Not existing in this patient file
|
|---|
| 103 | . I F["~" S FNUM=+F,FNAME=$P($P(F,"~"),FNUM,2),F=FNUM K FNUM
|
|---|
| 104 | . S FNAME=$S($L($G(FNAME)):FNAME,$L($G(^DD(2,F,.1))):$P(^(.1),"^"),1:$P(^DD(2,F,0),"^"))
|
|---|
| 105 | . S FVALUE="" ;Patient Data
|
|---|
| 106 | . S FHELP=$G(^DD(2,F,3))
|
|---|
| 107 | . I F'=27.02,'$L(FHELP) S N=0 F S N=$O(^DD(2,F,21,N)) Q:'+N S FHELP=FHELP_^(N,0)
|
|---|
| 108 | . S FHELP=$TR(FHELP,"'","`")
|
|---|
| 109 | . S FPSC=$P(^DD(2,F,0),"^",3)
|
|---|
| 110 | . S SUBDIC=+$P(^DD(2,F,0),"^",2)
|
|---|
| 111 | . S RESULT($$INR)=FNAME_"^"_F_"^"_FVALUE_"^"_FHELP_"^"_FPSC_$S(SUBDIC:"^1",1:"^0")
|
|---|
| 112 | . S (FNAME,FVALUE,FHELP,FPSC)=""
|
|---|
| 113 | G NPTX:'DFN
|
|---|
| 114 | I DFN D GETS^DIQ(2,DFN_",","**","EN","AR") ;,RESULT(0)=$$DFNID^VWREGITU
|
|---|
| 115 | K FIELD S N=0 F S N=$O(RESULT(N)) Q:'+N S FIELD($P(RESULT(N),"^",2))=""
|
|---|
| 116 | S X="AR" F S X=$Q(@X) Q:X="" D
|
|---|
| 117 | . S FILE=+$P(X,"(",2)
|
|---|
| 118 | . S FIELD=+$P(X,",",$L(X,",")-1)
|
|---|
| 119 | . I $D(FIELD(FIELD)) S FIELD(FIELD)=@X
|
|---|
| 120 | S N=0 F S N=$O(FIELD(N)) Q:'+N D
|
|---|
| 121 | . S N2=0 F S N2=$O(RESULT(N2)) Q:'+N2 I $P(RESULT(N2),"^",2)=N S $P(RESULT(N2),"^",3)=FIELD(N)
|
|---|
| 122 | . S RESULT(0)=$$DFNID^VWREGITU()
|
|---|
| 123 | NPTX K FIELD,AR,FCAP,FILE,SUBDIC,N,N2,DFN
|
|---|
| 124 | Q
|
|---|
| 125 | ;
|
|---|
| 126 | PF(RESULT,XPF) ;Pointer file - get the stuff
|
|---|
| 127 | K RESULT,AR
|
|---|
| 128 | N X,N
|
|---|
| 129 | I '$L(XPF) S RESULT(0)="???" Q
|
|---|
| 130 | S XPF="^"_XPF
|
|---|
| 131 | I +$P(XPF,"(",2)=.85 G NAUTPF ;Naughty file!
|
|---|
| 132 | S N=0 F S N=$O(@(XPF_N_")")) Q:'+N S X=$P(^(N,0),"^"),AR(X,N)=X_"("_N_")"
|
|---|
| 133 | S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
|---|
| 134 | K AR
|
|---|
| 135 | Q
|
|---|
| 136 | ;
|
|---|
| 137 | NAUTPF ;The "NAUGHTY" pointer file - has a numeric .01 - Bad file !!!
|
|---|
| 138 | S N=0 F S N=$O(@(XPF_N_")")) Q:'+N S X=$P(^(N,0),"^") D
|
|---|
| 139 | . S LANG=$P(^(0),"^",2)
|
|---|
| 140 | . S AR(LANG,N)=LANG_"("_N_")"
|
|---|
| 141 | S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
|---|
| 142 | Q
|
|---|
| 143 | GIF ;Generic Insurance form
|
|---|
| 144 | K RESULT
|
|---|
| 145 | S RESULT($$INR)="Insurance Company^2.312;.01^^^DIC(36,^0"
|
|---|
| 146 | S RESULT($$INR)="Group Plan^2.312;.18^^^IBA(355.3,^0"
|
|---|
| 147 | S RESULT($$INR)="Policy No.^2.312;1^^^^0"
|
|---|
| 148 | ;S RESULT($$INR)="Type of Plan^^^^^0"
|
|---|
| 149 | S RESULT($$INR)="Coverage^355.33;40.09^^^IBE(355.1,^0"
|
|---|
| 150 | S RESULT($$INR)="Effective Date^2.312;8^^^^0"
|
|---|
| 151 | S RESULT($$INR)="Expiration Date^.3121;^^^^0"
|
|---|
| 152 | S RESULT($$INR)="Guarantor^^^^^0"
|
|---|
| 153 | S RESULT($$INR)="Signature on File^^^^0:NO;1:YES^0"
|
|---|
| 154 | S RESULT($$INR)="Employer^2.312;2.015^^^^0"
|
|---|
| 155 | S RESULT($$INR)="Billing Address^2.312;2.02^^^^0"
|
|---|
| 156 | S RESULT($$INR)="Billing Address(cont)^2.312;2.03^^^^0"
|
|---|
| 157 | S RESULT($$INR)="Postal Code^2.312;2.07^^^^0"
|
|---|
| 158 | S RESULT($$INR)="City^2.312;2.05^^^^0"
|
|---|
| 159 | S RESULT($$INR)="County/Region/Area^^^^^0"
|
|---|
| 160 | S RESULT($$INR)="State/Province/Region^2.312;2.06^^^DIC(5,^0"
|
|---|
| 161 | Q
|
|---|
| 162 | ;
|
|---|
| 163 |
|
|---|
