VistA-VWGUIRegistration/VWREGITX.m

327 lines
12 KiB
Mathematica

VWREGITX ;Portland,OR/Jim Bell, et al - World VistA GUI Pat Reg Utility
;;2.0;WORLD VISTA;**LOCAL **;;Build 26
;*****************************************************************
;* Licensed under GNU 2.0 or greater - see license.txt file *
;* Program/application is for the management of input templates *
;* owned by the user (DUZ). *
;* REMINDER: All template fields pertain only to the Patient File*
;* (#2)! *
;*****************************************************************
;No fall thru
Q
;
1 ;CallerID = HRN; value is at $P($P(CALLERID,":",2),"^")
S HRN=$P($P(CALLERID,":",2),"^")
S HRN=$$HRN(HRN)
I HRN="" S RESULT(0)="The Health Record Number (HRN) does not exist in this database"_$C(13,10)_"Please use NAME, DOB, or PHONE#."
Q
;
2 ;CallerID = NAME; in ^2@+CALLERID
K AR,ARR
N HRN,PHONE,DOB,N
S NAME=$P(CALLERID,"^",+CALLERID)
S XNAME=NAME F S XNAME=$O(^DPT("B",XNAME)) Q:XNAME'[NAME D
. S N=0 F S N=$O(^DPT("B",XNAME,N)) Q:'+N S AR($O(AR(" "),-1)+1)=N
I $O(AR(" "),-1)=1 D Q
. S DFN=AR(1)
. S HRN=$$HRN(DFN),HRN=$S($L(HRN):HRN,'$L(HRN):"ID-"_$P($G(^DPT(DFN,.36)),"^",3),1:"------------")
. S DOB=$P(^DPT(DFN,0),"^",3),DOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$E(DOB,2,3)
. S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE):PHONE,1:"<No entry>")
. S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")^"_DOB_"^"_PHONE
S N=0 F S N=$O(AR(N)) Q:'+N S ARR($P(^DPT(+AR(N),0),"^"),N)=+AR(N)
S X="ARR" F S X=$Q(@X) Q:X="" S DFN=@X D
. S HRN=$$HRN(DFN),HRN=$S($L(HRN):HRN,'$L(HRN):"ID-"_$P($G(^DPT(DFN,.36)),"^",3),1:"------------")
. S DOB=$P(^DPT(DFN,0),"^",3),DOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$E(DOB,2,3)
. S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE):PHONE,1:"<No entry>")
. S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")^"_DOB_"^"_PHONE
K AR,ARR
Q
;
3 ;CallerID = DOB; in ^3@CALLERID
S X=$P(CALLERID,"^",+CALLERID)
K %DT,Y,AR
N HRN,PHONE,N
D ^%DT
S N=0 F S N=$O(^DPT("ADOB",Y,N)) Q:'+N S AR($O(AR(" "),-1)+1)=N_"^"_Y
I $O(AR(" "),-1)=1 D Q ;Only one find
. K RESULT
. S DFN=+AR(1)
. S HRN=$$HRN(DFN)
. I '$L(HRN) S HRN="ID-"_$P($G(^DPT(DFN,.36)),"^",3)
. I '$L(HRN) S HRN="------------"
. S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE)>0:PHONE,1:"<No entry>")
. S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")"_"^"_$P(CALLERID,"^",+CALLERID)_"^"_PHONE
K ARR S N=0 F S N=$O(AR(N)) Q:'+N S ARR($P(^DPT(+AR(N),0),"^"),N)=+AR(N)
S X="ARR" F S X=$Q(@X) Q:X="" S DFN=@X D
. S HRN=$$HRN(DFN)
. I '$L(HRN) S HRN=$P($G(^DPT(DFN,.36)),"^",3)_"(ID)"
. I '$L(HRN)!(HRN="(ID)") S HRN="------------"
. S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE)>0:PHONE,1:"<No entry>")
. S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")"_"^"_$P(CALLERID,"^",+CALLERID)_"^"_PHONE
K ARR,AR
Q
;
4 ;CallerID = PHONE; IN ^4@+CALLERID
S CALLERID=$TR(CALLERID,"- ()","")
Q
;
5 ;CallerID = space-bar; IN ^2@+CALLERID
S X=$P(CALLERID,"^",+CALLERID)
S DFN=$G(^DISV(DUZ,"^DPT("))
I 'DFN S RESULT(0)="Patient-Client not found" Q
S AR(1)=DFN G 2+6 ;Direct call
Q
;
DE(RESULT,DATA) ;Forced hard error
;W "
Q
;
HRN(IEN) ;Health Record #s from IHS PATIENT
N N,HRNIEN,I
S HRNIEN=""
Q:'$D(^AUPNPAT(IEN)) HRNIEN
S N=0 F I=1:1 S N=$O(^AUPNPAT(IEN,41,N)) Q:'+N S HRNIEN=HRNIEN_$P($G(^AUPNPAT(IEN,41,N,0)),"^",2)_"|"
I $E(HRNIEN,$L(HRNIEN))="|" S HRNIEN=$E(HRNIEN,1,$L(HRNIEN)-1)
Q HRNIEN
;
ALIST(RESULT,ALPHA,CALLERID) ;Alpha request from client
;*****************************************************
;* ALPHA_____Letter to look up *
;* CALLERID__PIECE#:HRN^NAME(IEN)^DOB^PHONE look up *
;* RETURN____HRN^NAME^DOB^PHONE(Field .131 in File 2)*
;*****************************************************
I '$L(ALPHA),'+CALLERID S RESULT(0)="No Alphabetical letter or HRN,Name,DOB,Phone selection..." Q
S CALLERID=$$UP^XLFSTR(CALLERID) ;Upcase EVERYTHING
I +CALLERID G @+CALLERID
N X,I,ANAME,HRN,ADOB,APHONE,Y
K RESULT,AR,ARR
S X="^DPT(""B"""_","_""""_ALPHA_""")"
F I=1:1 S X=$Q(@X) Q:$S($L(ALPHA)>1:$P(X,"""",4)'[ALPHA,1:$E($P(X,"""",4))'=ALPHA) S AR(I)=+$P(X,",",$L(X,","))
S ARN=0 F S ARN=$O(AR(ARN)) Q:'+ARN D
. S HRN=$$HRN(ARN)
. S:'$L(HRN) HRN="--- "
. F JJ=$L(HRN):1:15 S HRN=HRN_" "
. S ANAME=$P(^DPT(AR(ARN),0),"^")
. S Y=$P(^(0),"^",3)_$S($G(^DPT(AR(ARN),540000)):^(540000),1:"")
. D DD^%DT S ADOB=Y
. S APHONE=$P($G(^DPT(AR(ARN),.13)),"^")
. S ARR(ANAME,ARN)=HRN_"^"_ANAME_"("_AR(ARN)_")^"_ADOB_"^"_APHONE
S X="ARR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
Q
;
PLID(IEN) ;Primary Long ID, used with or in absence of HRN.
Q $P($G(^DPT(IEN,.36)),"^",3)
;
INR() Q $O(RESULT(" "),-1)+1
;
FIXNAME ;
N N,X,Y,XIEN,NLENGTH,I
S NLENGTH=0,X="AR" F S X=$Q(@X) Q:X="" D
. S Y=@X,N=$P(Y,"(")_"("_+$P(Y,"(",2)_")",STR=$P(Y,")",2)
. S NLENGTH=$S($L(N)>NLENGTH:$L(N),1:NLENGTH)
. F I=NLENGTH:-1:$L(N) S N=N_" "
. S Y=N_" "_STR
. S @X=Y
Q
GPL(RESULT,IDDATA) ;Partial patient lists
;***********************************************
;* IDDATA_____Contains Start^Stop alpha chars *
;* RESULT_____Return of results *
;***********************************************
K RESULT,AR
N N,DFN,SSN,DOB,START,STOP,NAME,XDOB ;; ,NL
;;Get user's last patient ID
S DFN=$G(^DISV(DUZ,"^DPT(")) D:DFN
. S NAME=$P(^DPT(DFN,0),"^")
. ;S SSN=$P(^(0),"^",9)
. S HRN="HRN: "_$$HRN(DFN) ;Health record number
. S PLID="ID: "_$$PLID(DFN) ;Primary Long ID
. S DOB=$P(^(0),"^",3)
. S XDOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$S($E(DOB)<3:19,1:20)_$E(DOB,2,3)
. S AR(0)=NAME_"("_DFN_")"_" "_XDOB_" "_$S($L($P(HRN,": ",2)):HRN,$L($P(PLID,": ",2)):PLID,1:"<NO ID ON FILE>")
S START=$P(IDDATA,"^")
S STOP=$P(IDDATA,"^",2)
S STOP=STOP_"z"
S STOP=$E($O(^DPT("B",STOP)))
S STOP=$S('$L(STOP):$P(IDDATA,"^",2)_"z",1:STOP)
S NL=0
S N=START F S N=$O(^DPT("B",N)) Q:N=""!($E(N)=STOP) D
. S DFN=$O(^(N,0))
. S NAME=$P(^DPT(DFN,0),"^")_"("_DFN_")"
. ;S SSN=$P(^(0),"^",9),SSN=$S('$L(SSN):" ????",1:SSN)
. S HRN="HRN: "_$$HRN(DFN)
. S PLID="ID: "_$$PLID(DFN) ;Primary Long ID
. S DOB=$P(^DPT(DFN,0),"^",3)
. S XDOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$S($E(DOB)<3:19,1:20)_$E(DOB,2,3)
. ;W !,$J(DFN,5)," ",$J($E(NAME,1,12),12)," ",$J(SSN,10)," ",XDOB
. S AR(NAME,DFN)=NAME_" "_XDOB_" "_$S($L($P(HRN,": ",2)):HRN,$L($P(PLID,": ",2)):PLID,1:"<NO ID ON FILE>")
. S (DFN,NAME,SSN,DOB,XDOB)=""
D FIXNAME
S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
K AR
Q
;
REJECT(FIELD,IEN,SUBDIC) ;Reject Asterisked,Amis,Computed fields,VA specific fields
;This subroutine left in for possible future use
I $L(IEN),$D(^DIZ(64850001,IEN)) Q 1 ;VA specific data field
I FIELD["COMPONENT" Q 1 ;Pain in the butt!
I FIELD["(VA)"!(FIELD["(CIVIL)") Q 1 ;VA fields
I FIELD["AMIS",FIELD["SEGMENT" Q 1
I FIELD["ELIG VERIF" Q 1
I FIELD["ENCOUNTER CONVERSION" Q 1
I FIELD["PROGRAMMERS U" Q 1
I FIELD["WHO " Q 1
I FIELD["SC AT"!(FIELD["SC%") Q 1
I $E(FIELD)="*" Q 1 ;field marked for deletion
I FIELD["10-10" Q 1
I $L(IEN),$E($P($G(^DD(2,IEN,0)),"^",2))="C" Q 1 ;computed field
I $L($G(SUBDIC)),$E($P($G(^DD(SUBDIC,IEN,0)),"^",2))="C" Q 1 ;computet in sub-dic
Q 0 ;Passed
;
LF(RESULT,FTYPE) ;List of assumed civilian type fields from
; Patient file(#2)
;*******************************************************************
;*The author (me) arbitarily selected fields from the patient file *
;* that he (me) considers to be usable by civilian VistA/CPRS users*
;* the field count is 284 out of the 700+ fields available in the *
;* full patient DD. File is located at ^DIZ(64850002, *
;*******************************************************************
;
S FTYPE=$TR(FTYPE,"*&^%$#@!:;>?/., ","") ;TMenuItem inclusions/jeb
;S:$L(FTYPE) FTYPE=$P(^DIZ(64850003,+$P(FTYPE,"(",2),0),"^")
S FTYPE=$$UP^XLFSTR(FTYPE)
K RESULT
N N,X,FIELD,FLDNO,FGRP,M,MX,MF,MFNO,MFGP,MN
G FG:$L(FTYPE)
; Add patient file fields
S N=0 F S N=$O(^DIZ(64850002,N)) Q:'+N D
. S X=^(N,0)
. S FIELD=$P(X,"^")
. S FLDNO=$P(X,"^",2)
. S FGRP=$P(X,"^",3)
. S RESULT($$INR)=FIELD_"("_FLDNO_")"_":"_FGRP
. I $O(^DIZ(64850002,N,"M",0)) D
.. S M=0 F S M=$O(^DIZ(64850002,N,"M",M)) Q:'+M D
... S MX=^(M,0)
... S MF=$P(MX,"^")
... S MFNO=$P(MX,"^",2)
... S MFGP=$P(MX,"^",3)
... S RESULT($$INR)=" SF "_MF_"("_MFNO_")"_":"_MFGP
S X="RESULT" F I=1:1 S X=$Q(@X) Q:X=""
S RESULT(0)="Field count: "_(I-1)
Q
;
FG ;Fields by GROUP
Q:'$L(FTYPE)
K RESULT,AHF N LABEL,F,N,I
S N=$S(+$P(FTYPE,"(",2):+$P(FTYPE,"(",2),1:$O(^DIZ(64850003,"B",FTYPE,0)))
I 'N S RESULT($$INR)="Group not found." G FGX
S F=0 F I=1:1 S F=$O(^DIZ(64850003,N,"F","B",F)) Q:'+F S RESULT($$INR)=$P(^DD(2,F,0),"^")_"("_F_")"
FGX Q
;
FGNA(RESULT,KIND) ;Fields by sort designator
;**********************************
;* KIND *
;* G____Group,Field *
;* N____Field# *
;* A____Alphabetical (Default) *
;* RESULT__Returned array *
;**********************************
K RESULT
I KIND="G" D G FGNAX
. K AR
. S N=0 F S N=$O(^DIZ(64850002,N)) Q:'+N S X=^(N,0) D
.. S GRP=$P(X,"^",3)
.. S FN=$P(X,"^",2)
.. S FIELD=$P(X,"^")
.. S AR(GRP,FN)=FIELD_"("_FN_")"
.. I $O(^DIZ(64850002,N,"M",0)) D
... S MN=0 F S MN=$O(^DIZ(64850002,N,"M",MN)) Q:'+MN D
.... S MX=^(MN,0)
.... S MFN=+$P(MX,"^",2)
.... S MFLD=$P(MX,"^")
.... S AR(GRP,FN,MFN)=" SF "_$P(MX,"^")_"("_$P(MX,"^",2)_")"
. S G="" F S G=$O(AR(G)) Q:G="" S RESULT($$INR)="--- "_G_" ---" D
.. S FN=0 F S FN=$O(AR(G,FN)) Q:'+FN S X=AR(G,FN),RESULT($$INR)=$P(X,"^") I $O(AR(G,FN,0)) S SFN=0 F S SFN=$O(AR(G,FN,SFN)) Q:'+SFN S RESULT($$INR)=AR(G,FN,SFN)
I KIND="N" D G FGNAX
. K AR,RESULT
. S N=0 F S N=$O(^DIZ(64850002,N)) Q:'+N S X=^(N,0) D
.. S GRP=$P(X,"^",3)
.. S FN=$P(X,"^",2)
.. S FIELD=$P(X,"^")
.. S AR(FN)=FIELD_"("_FN_")"
.. I $O(^DIZ(64850002,N,"M",0)) D
... S MN=0 F S MN=$O(^DIZ(64850002,N,"M",MN)) Q:'+MN D
.... S MX=^(MN,0)
.... S MFN=+$P(MX,"^",2)
.... S MFLD=$P(MX,"^")
.... S AR(FN,MFN)=" SF "_$P(MX,"^")_"("_$P(MX,"^",2)_")"
. S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
;Kind = alphabetical
S N=0 F S N=$O(^DIZ(64850002,N)) Q:'+N S X=^(N,0) D
. S AR($P(X,"^"))=$P(X,"^")_"("_$P(X,"^",2)_")"
. I $O(^DIZ(64850002,N,"M",0)) D
.. S MN=0 F S MN=$O(^DIZ(64850002,N,"M",MN)) Q:'+MN D
... S MX=^(MN,0)
... S MFN=+$P(MX,"^",2)
... S MFLD=$P(MX,"^")
... S AR($P(X,"^"),MFLD)=" SF "_$P(MX,"^")_"("_$P(MX,"^",2)_")"
S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
FGNAX ;K AR
Q
;
RETGRP(RESULT) ;Return Group IDs
K RESULT
S N=0 F S N=$O(^DIZ(64850003,N)) Q:'+N S RESULT($$INR)=$P(^(N,0),"^",2)_"("_N_")"
Q
;
AHF(RESULT,AHF) ;Ad hoc field selection "Finished" pressed/jeb
;*****************************************************
;* AFH ARRAY: *
;* AHF(0)____DFN *
;* AHF ARRAY_FIELD(NO) OR FIELD(NO;SUB-DIC) *
;*****************************************************
;W " ;the END
K ^DIZ("AHF") M ^DIZ("AHF")=AHF
K RESULT
N FIELD,FNO,DFNDR
S DFNDR=""
S DFN=+AHF(0) K AHF(0)
S X="AHF" F S X=$Q(@X) Q:X="" S Y=@X D
. S FIELD=$P(Y,"(")
. S FNO=+$P(Y,"(",2)
. D GFA(FNO)
. S RESULT($$INR)=FIELD_"^"_FNO_"^^"_FHELP_"^"_FPSC_"^"_$$MF(FNO)
. S DFNDR=DFNDR_FNO_";"
I DFN D
. K AR N N,Y,F
. D GETS^DIQ(2,DFN_",",DFNDR,"E","AR","ERR")
. S X="AR" F S X=$Q(@X) Q:X="" D
.. S Y=@X
.. S F=+$P(X,",",$L(X,",")-1)
.. S N=0 F S N=$O(RESULT(N)) Q:'+N I $P(RESULT(N),"^",2)=F S $P(RESULT(N),"^",3)=Y
;ToDo: write fill in for the multiple fields
K FHELP,FPSC
Q
;
GFA(FNO) ;Get field attributes at piece3 and help
S (FHELP,FPSC)=""
S FHELP=$G(^DD(2,FNO,3))
I FNO'=27.02 S N=0 F S N=$O(^DD(2,FNO,21,N)) Q:'+N S FHELP=FHELP_^(N,0)
S FHELP=$TR(FHELP,"'","`")
S FPSC=$P(^DD(2,FNO,0),"^",3)
Q
;
MF(X) ;Check for multiple field
;*****************************************************
;* Reminder: This data set is Patient file only (#2) *
;* MYESNO____=1 is a parent *
;* =0 is a primary field *
;*****************************************************
;
S MYESNO=$S(+$P(^DD(2,X,0),"^",2):1,1:0)
Q MYESNO
;