iSharkFly-Open
/
VistA-VWGUIRegistration
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

This commit is contained in:
jbell 2017-03-08 22:10:56 +00:00
parent d4da486f57
commit 7eabd8c1a4
8 changed files with 0 additions and 1082 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
VWREGIT.m
View File

@ -1,162 +0,0 @@
VWREGIT ;Portland,OR/Jim Bell, et al Patient Registration Utility August 2015
;;2.0;B/FProductions,LLC,WORLD VISTA;**LOCAL**;;Build 2
;*******************************************************************
;* VW Registration is designed for patient specific fields as *
;* defined in Fileman Input Templates or ad hoc field selection. *
;* Copyright Martius/MMXV ad infinitum (GNU License: See GPLv3.txt)*
;*******************************************************************
;;NO FALL THROUGH - JEB
Q
;
TFM(XF) ;TemplateField Management
;***********************************************
;* Check primary field entries for "parentage" *
;* Add an "*" to gain all sub-fields of the *
;* parent *
;* REMEMBER: All fields pertain to file 2 only *
;***********************************************
N I,N,FIELD
K FARRAY
I '$L(XF),'$G(TNUM) Q ""
I '$L(XF),+$G(TNUM) S XF=^DIE(TNUM,"DR",1,2)
F I=1:1:$L(XF,";") S:$L($P(XF,";",I)) FARRAY(I)=+$P(XF,";",I)
S N=0 F I=1:1 S N=$O(FARRAY(N)) Q:'+N D
. S FIELD=FARRAY(N)
. I +$P(^DD(2,FIELD,0),"^",2) S FIELD=FIELD_"*",FMARRAY(FIELD)=$P(^(0),"^",4) K FARRAY(N)
S XF="",N=0 F S N=$O(FARRAY(N)) Q:'+N S XF=XF_FARRAY(N)_";"
Q XF
;
CHECK() ;
Q ""
;
INR() Q $O(RESULT(" "),-1)+1
;
EN(RESULT) ;Template name and ID labels
;Get the input template list
;housekeeping
S DTIME=99999
ZSY "chmod 777 "_$ZD_"regparam/*.txt"
;end housekeeping
;
K AR,RESULT
N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO,DEFST,XTMP,X
S RESULT(0)=1
S DEFST="";
;S DEFTMP=$O(^DIE("B","FAU_EDU",0)) ;For Florida College only
S RESULT(0)=$$CONTROL^VWREGITU()
S RESULT(1)="-1^No templates found"
S DEFST=$$GET^XPAR("ALL","VW REG DEFAULT STATE")
S DEFTMP=$$GET^XPAR("ALL","VW REG RDNPT")
S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
I '$L(HD) K RESULT D Q
. S RESULT($$INR)="-1^NO HOME DIRECTORY - refer to IT support, if necessary."
. S RESULT($$INR)="No home directory has been supplied which indicates"
. S RESULT($$INR)="the VWREG installation is incomplete. See the Help manual"
. S RESULT($$INR)="for installation and Enter/Editing parameter values."
. S RESULT($$INR)="Thank you,"
. S RESULT($$INR)=" The Management."
S FILE="regit.txt"
S P4=1
S P5=""
S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
D:+RESULT(0)
. S $P(RESULT(0),"^",2)=$G(HD)
. S $P(RESULT(0),"^",3)=$S(DEFST:$P(^DIC(5,DEFST,0),"^")_"("_DEFST_")",1:"")
. S $P(RESULT(0),"^",4)=$S(+DEFTMP:$P(^DIE(DEFTMP,0),"^")_"("_DEFTMP_")",1:DEFTMP)
. S $P(RESULT(0),"^",5)=DUZ
I $O(AR(0)) S RESULT(1)="[TEMPLATES]"
S N=0 F S N=$O(AR(N)) Q:'+N D
. Q:$E(AR(N))="*"
. Q:'+$P(AR(N),"(",2)
. Q:$P($G(^DIE(+$P(AR(N),"(",2),0)),"^",4)'=2 ;must be pat file
. S RESULT($$INR)=AR(N)
S RESULT($$INR)="[ID]"
;S N=0 F S N=$O(^DIZ(64850003,N)) Q:'+N S RESULT($$INR)=$P(^(N,0),"^",2)_"("_$P(^(0),"^")_")"
;S N=0 F S N=$O(RESULT(N)) Q:'+N K:RESULT(N)="" RESULT(N)
I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found"
K AR
Q
;
NPT(RESULT,TNAME) ;
; *************************************************
; * Incoming: DFN^TEMPLATE NAME(IEN) *
; * Process : Get template fields plus any help *
; * If +TNAME (a DFN), get DFN data for *
; * the template fields (Put data in *
; * $P(RESULT(N),"^",3)) *
; * Return : RESULT(N), etc *
; *************************************************
;W " ;Intentional bust for debugging
N N,TNUM,FIELDS,F,FNAME,FVALUE,FHELP,FPSC,FNUM
S TNUM=+$P(TNAME,"(",2),DFN=+TNAME
I 'TNUM S RESULT(0)="0^new patient Template not found" Q
S TNAME=$P($P(TNAME,"^",2),"(")
S TNAME=$TR(TNAME,"$&*","") ;Clean out TMENU chars
I TNAME="GENERIC INS. FRM [WorldVistA]" G GIF
S FIELDS=$G(^DIE(TNUM,"DR",1,2))
I '$L(FIELDS) Q
K RESULT S (FNUM,FCAP)=""
F I=1:1:$L(FIELDS,";")-1 D
. S F=$P(FIELDS,";",I)
. Q:'$D(^DD(2,F)) ;Not existing in this patient file
. I F["~" S FNUM=+F,FNAME=$P($P(F,"~"),FNUM,2),F=FNUM K FNUM
. S FNAME=$S($L($G(FNAME)):FNAME,$L($G(^DD(2,F,.1))):$P(^(.1),"^"),1:$P(^DD(2,F,0),"^"))
. S FVALUE="" ;Patient Data
. S FHELP=$G(^DD(2,F,3))
. 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)
. S FHELP=$TR(FHELP,"'","`")
. S FPSC=$P(^DD(2,F,0),"^",3)
. S SUBDIC=+$P(^DD(2,F,0),"^",2)
. S RESULT($$INR)=FNAME_"^"_F_"^"_FVALUE_"^"_FHELP_"^"_FPSC_$S(SUBDIC:"^1",1:"^0")
. S (FNAME,FVALUE,FHELP,FPSC)=""
G NPTX:'DFN
I DFN D GETS^DIQ(2,DFN_",","**","EN","AR") ;,RESULT(0)=$$DFNID^VWREGITU
K FIELD S N=0 F S N=$O(RESULT(N)) Q:'+N S FIELD($P(RESULT(N),"^",2))=""
S X="AR" F S X=$Q(@X) Q:X="" D
. S FILE=+$P(X,"(",2)
. S FIELD=+$P(X,",",$L(X,",")-1)
. I $D(FIELD(FIELD)) S FIELD(FIELD)=@X
S N=0 F S N=$O(FIELD(N)) Q:'+N D
. S N2=0 F S N2=$O(RESULT(N2)) Q:'+N2 I $P(RESULT(N2),"^",2)=N S $P(RESULT(N2),"^",3)=FIELD(N)
. S RESULT(0)=$$DFNID^VWREGITU()
NPTX K FIELD,AR,FCAP,FILE,SUBDIC,N,N2,DFN
Q
;
PF(RESULT,XPF) ;Pointer file - get the stuff
K RESULT,AR
N X,N
I '$L(XPF) S RESULT(0)="???" Q
S XPF="^"_XPF
I +$P(XPF,"(",2)=.85 G NAUTPF ;Naughty file!
S N=0 F S N=$O(@(XPF_N_")")) Q:'+N S X=$P(^(N,0),"^"),AR(X,N)=X_"("_N_")"
S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
K AR
Q
;
NAUTPF ;The "NAUGHTY" pointer file - has a numeric .01 - Bad file !!!
S N=0 F S N=$O(@(XPF_N_")")) Q:'+N S X=$P(^(N,0),"^") D
. S LANG=$P(^(0),"^",2)
. S AR(LANG,N)=LANG_"("_N_")"
S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
Q
GIF ;Generic Insurance form
K RESULT
S RESULT($$INR)="Insurance Company^2.312;.01^^^DIC(36,^0"
S RESULT($$INR)="Group Plan^2.312;.18^^^IBA(355.3,^0"
S RESULT($$INR)="Policy No.^2.312;1^^^^0"
;S RESULT($$INR)="Type of Plan^^^^^0"
S RESULT($$INR)="Coverage^355.33;40.09^^^IBE(355.1,^0"
S RESULT($$INR)="Effective Date^2.312;8^^^^0"
S RESULT($$INR)="Expiration Date^.3121;^^^^0"
S RESULT($$INR)="Guarantor^^^^^0"
S RESULT($$INR)="Signature on File^^^^0:NO;1:YES^0"
S RESULT($$INR)="Employer^2.312;2.015^^^^0"
S RESULT($$INR)="Billing Address^2.312;2.02^^^^0"
S RESULT($$INR)="Billing Address(cont)^2.312;2.03^^^^0"
S RESULT($$INR)="Postal Code^2.312;2.07^^^^0"
S RESULT($$INR)="City^2.312;2.05^^^^0"
S RESULT($$INR)="County/Region/Area^^^^^0"
S RESULT($$INR)="State/Province/Region^2.312;2.06^^^DIC(5,^0"
Q
;

61
VWREGIT2.m
View File

@ -1,61 +0,0 @@
VWREGIT2 ;Portland/WorldVista/BFP,LLC/Jim Bell, et al... - Post-Install for VWREG
;;1.0;WORLD VISTA;**HOME **;;Build 2
;
;Continued from VWREGIT
;
;GNU License: See WVLIC.txt
;Modified FOIA VISTA,
;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
Q
PRE ;Did this installation happen already? Avoid a re-do?
I $O(^XMB(3.8,"B","VW REG ERROR REPORT",0))&($D(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))) W !?5,"Installation has already occurred"
W !,"Do you want to continue? NO//" R X:60 S:'$L(X) X="NO" S X=$$UP^XLFSTR(X)
I "NON"[X W !,"OK" D ^XUSCLEAN
Q
;
PI ;Post Installation install
;Checking for a home directory & file
I $O(^XMB(3.8,"B","VW REG ERROR REPORT",0)) W !?5,"Installation has already occurred" Q
S AR=1,AR(1)="[TEMPLATES]"
S N=0 F S N=$O(^DIE(N)) Q:'+N S X=$P(^(N,0),"^") D
. I X["VW " S AR($I(AR))=X_"("_N_")"
. I X["[World" S AR($I(AR))=X_"("_N_")"
S AR($I(AR))="[ID]"
S P4=1,P5="",HD=$ZDIRECTORY_"regparam/",FILE="regit.txt"
S X=$$GTF^%ZISH($NA(AR(1)),1,HD,"regit.txt")
ZSY "chmod 777 "_$ZDIRECTORY_"regparam/"_FILE ;No sensitive info here
Q:$G(TEST) ;Straightening out regit.txt
;
;; NOTE: The parameter definition is installed but there is no installation for
;;the actual parameter and value. Do it here.
;parameter value attempt
;Set a home directory for editing; SYSTEM (DIC(4,) and DOMAIN (DIC(4.2,) only:"/home/vista/regparam/"
S PARD=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))
I PARD D
. L +^XTV(8989.5,0):1 D L -^XTV(8989.5,0)
.. S NEW=$O(^XTV(8989.5," "),-1)+1
.. S $P(^XTV(8989.5,0),"^",3)=NEW
.. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
.. S $P(^XTV(8989.5,NEW,0),"^")="1;DIC(4,"
.. S $P(^XTV(8989.5,NEW,0),"^",2)=PARD
.. S $P(^XTV(8989.5,NEW,0),"^",3)=1
.. S ^XTV(8989.5,NEW,1)=HD
.. S DA=NEW,DIK="^XTV(8989.5," D IX^DIK
.. S NEW2=$O(^XTV(8989.5," "),-1)+1
.. S $P(^XTV(8989.5,0),"^",3)=NEW2
.. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
.. S $P(^XTV(8989.5,NEW2,0),"^")="9;DIC(4.2,"
.. S $P(^XTV(8989.5,NEW2,0),"^",2)=PARD
.. S $P(^XTV(8989.5,NEW2,0),"^",3)=1
.. S ^XTV(8989.5,NEW2,1)=HD
.. S DA=NEW2,DIK="^XTV(8989.5," D IX^DIK
;
;Mailgroup VW REG ERROR REPORT - add programmer's email
S DA(1)=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0))
Q:'DA(1)
S DIC="^XMB(3.8,"_DA(1)_",6,"
S X="jbellco65@gmail.com"
S DIC(0)="LZ"
D FILE^DICN
Q
;

11
VWREGIT3.m
View File

@ -1,11 +0,0 @@
VWREGIT3 ;VWEHR/BFProd-Jim Bell, et al - World VistA GUI Pat Reg Utility
;;1.0;WORLD VISTA;** **;;Build 2
;
;This routine utility is for patient specific fields and
;is used to build input templates for registration
;
;GNU License: See WVLIC.txt
;Modified FOIA VISTA,
;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
Q
;

57
VWREGITP.m
View File

@ -1,57 +0,0 @@
VWREGITP ;BFP/Portland,OR-Jim Bell,et al - Client Registration Utility
;2.0;BFP for WorldVistA;**LOCAL**;;;Build 2
; *******************************************
; * Copyright 2015 ad infinitum et ultra *
; * Gets data for existing clients/patients *
; * GPL License: See License.txt *
; *******************************************
Q ;No fall through - jeb
;
GPD(RESULT,DATA) ;Get patient data
; ********************************* 8888***
; * DATA_____TEMPLATE(IEN)^FIELDSET^DFN *
; * TEMPLATE__The name(IEN) of a *
; * stored template *
; * FIELDSET_Adhoc fields in a string *
; * as ".01;3;5;.131", etc *
; * DFN______IEN of patient file(#2) *
; * NOTE: TEMPLATE takes precedence *
; * over FIELDSET *
; *****************************************
;
K RESULT,AR
N VAR,TNUM,FSET,F,DFN
I '$L(DATA) S RESULT(0)="No information relayed. Please try again" Q
I $P(DATA,"^",3)="" S RESULT(0)="Patient info not relayed. Please try again" Q
S VAR="TNUM^ADHOC^DFN" F I=1:1:3 S @$P(VAR,"^",I)=$P(DATA,"^",I)
S TNUM=$S(TNUM["(":+$P(TNUM,"(",2),1:TNUM)
S DFN=+$P($P(DATA,"^",3),"(",2)
S FSET=$S(TNUM:^DIE(TNUM,"DR",1,2),'TNUM&($L(ADHOC)):ADHOC,1:"")
D GETS^DIQ(2,DFN_",","**","N","AR")
F I=1:1:$L(FSET,";") D
. Q:'$L($P(FSET,";",I))
. S F=+$P(FSET,";",I)
. S RESULT($$INR^VWREGIT)=F_"^"_$G(AR(2,DFN_",",F))
Q
GPDM(RESULT,DATA) ;
; ****************************************************************
; * DATA____Parent Text^Parent field #^PATIENT IEN^TEMPLATE(IEN) *
; ****************************************************************
N F,SUBD,DFN,PIEN,X,RIND,FILE,X,Y,TNUM
K MX,MAR,RESULT,AR
S DFN=+$P(DATA,"^",3)
S F=+$P(DATA,"^",2)
S TNUM=+$P($P(DATA,"^",4),"(",2)
D GETS^DIQ(2,DFN_",",F_"*;","E","AR")
S SUBD=+$P(^DD(2,F,0),"^",2) D:+SUBD ;Multiple field values
. S MX="AR("_SUBD_")" F S MX=$Q(@MX) Q:MX=""!(+$P(MX,"(",2)'=SUBD) D:$P(MX,",",$L(MX,",")-1)'=.01
.. S FILE=SUBD,PIEN=$P(MX,",",2,$L(MX,",")-1),PIEN=$TR(PIEN,"""","")
.. K MAR,IMAR
.. D GETS^DIQ(FILE,PIEN,"**","E","MAR")
.. D GETS^DIQ(FILE,PIEN,"**","I","IMAR")
.. S X=$Q(@"MAR"),Y=$Q(@"IMAR")
.. I @X'=@Y S @X=@X_"("_@Y_")"
.. S X="MAR" ;,RIND=$$INR^VWREGIT
.. S RIND=$$INR^VWREGIT,RESULT(RIND)="" F S X=$Q(@X) Q:X="" S RESULT(RIND)=RESULT(RIND)_@X_"^"
K AR,MAR,IMAR,MX
Q

115
VWREGITS.m
View File

@ -1,115 +0,0 @@
VWREGITS ;Portland,OR/jeb et al Save utility for VWREG* routines 11/2015
;V.2;;**LOCAL**;;;Build 2
;c2014 ad infiniti, BellFelder Productions (BF Productions) & WorldVistA
;License: See License.txt that with install
;No fall thru - jeb
Q
;
;* *****************************************************************
;* Data coming in may be for a new case or existing case *
;* Incoming: Array LDATA= *
;* LDATA(1)=Field^Field number^value^[optional]DFN *
;* LDATA(N...)=Field^Field number^value *
;* Exception for Multiples: *
;* LDATA(N)=Field(SUBDD;Field number):value(IEN)^...etc for every*
;* field that is a dependent of the parent *
;* Process: *
;* 1. call is at Label SAVE *
;* 2. Some housekeeping that this programmer needs to do proper *
;* string evaluations. *
;* 3. Filing of a new case with FILE^DICN. *
;* 4. Remaining major fields are filed with DIE *
;* 5. Multiples are filed with UPDATE^DIE *
;* 6. Existing entries will contain only edited data and will *
;* address those fields as in 4 & 5. *
;* Bon Appettit, et al. *
;*******************************************************************
SAVE(RESULT,LDATA) ;
K RESULT,^DIZ("DS",$J)
M ^DIZ("DS",$J)=LDATA
Q ;Testing
N DFN,DIC,DA,DR,VAR,FIELD,N,N1,X,Y,DIE,DIK
I $D(LDATA)<10 S RESULT(0)="-1: No data sent for filing. Please contact your IT dept." Q
;UPcase everyTHING
S XDAT="LDATA" F S XDAT=$Q(@XDAT) Q:XDAT="" S @XDAT=$$UP^XLFSTR(@XDAT)
;
;Incoming housekeeping
S X="LDATA" F I=1:1 S X=$Q(@X) Q:X="" I @X[":",@X[";" S ^DIZ("DS",$J,I)=@X K @X
I +$P(@$Q(LDATA),"^",4)!(+$P(@$Q(LDATA),"(",2)) G EXP ;DFN sent by client
S N=0 F S N=$O(LDATA(N)) Q:'+N I +$P($G(^DD(2,+$P(LDATA(N),"^",2),0)),"^",2) K LDATA(N)
S DFN=$$FIND1^DIC(2,"","M",$P(LDATA(1),"^",3),"","","ERR")
G EXP:DFN ;Found patient/client
;End housekeeping;
;
S X=$P(LDATA(1),"^",3) D
. S DIC="^DPT(",DIC(0)="LZ" K D0 D FILE^DICN S (DA,DFN)=+Y
. S DIC="^AUPNPAT(",DIC(0)="LZ",X=DFN,DINUM=X,DIC(0)="L" D FILE^DICN
. S DIE=DIC,DR=.03_"////^S X=DT" D ^DIE
. S DR=.11_"////^S X=DUZ" D ^DIE
LDPT L +^DPT(DFN):1 G LDPT:'$T
S N=1 F S N=$O(LDATA(N)) Q:'+N D
. Q:$P(LDATA(N),"^",2)[";"
. Q:'+$P(LDATA(N),"^",2) ;Marker of some kind
. S FIELD=$P(LDATA(N),"^",2)
. S VAR=$P(LDATA(N),"^",3)
. I FIELD=.03 D
.. S VAR=$$DC(VAR)
.. S VARTIME=$P(VAR,".",2),VAR=$P(VAR,".")
.. I $L(VARTIME) D
... N FDA
... S FDA(2,DFN_",",540000.1)=VARTIME
... D FILE^DIE("E","FDA")
... D CLEAN^DILF
. S:VAR["(" VAR=$S($L(VAR,"(")>2:+$P(VAR,"(",$L(VAR,"(")),1:+$P(VAR,"(",2))
. S DIE="^DPT(",DR=FIELD_"///"_$S(+VAR:"/",1:"")_"^S X=VAR" D ^DIE
L -^DPT(DFN)
D M ;File any multiple fields
S RESULT(0)="Filed..."
K ^DIZ("DS",$J)
Q
;
EXP ;Existing Patient
K X,FNAME,FFLD,FVALUE,AR,DIC,DA,DR,DIE,AR
S X="LDATA" F S X=$Q(@X) Q:X="" I @X[":" S AR($O(AR(" "),-1)+1)=@X K @X
S N=0 F S N=$O(LDATA(N)) Q:'+N S X=LDATA(N) D
. S FNAME=$P(X,"^")
. S FFLD=$P(X,"^",2)
. S FVALUE=$S($P(X,"^",3)["(":+$P(X,"(",2),1:$P(X,"^",3))
. S DFN=$P(X,"^",4)
. S DIE="^DPT(",DA=DFN,DR=FFLD_"///^S X=FVALUE" D ^DIE
D M
S RESULT($I(RESULT))="Filed..."
K X,FNAME,FFL,FVALUE,DFN,AR,DIE,DA,DR,DIC
Q
;
M ;File any multiples values; DFN should be defined above
Q:'$D(^DIZ("DS",$J))
M MULTS=^DIZ("DS",$J)
K MAR S N=0 F S N=$O(MULTS(N)) Q:'+N D
. F J=1:1:$L(MULTS(N),"^")-1 S MAR(J)=$P(MULTS(N),"^",J)
. S MX=$O(MAR(0))
. S MXFILE=+$P(MAR(MX),"(",2)
. S MXFLD=+$P(MAR(MX),";",2)
. S MXVAL=$P($P(MAR(MX),":",2),"(")
. I MXFLD=.01 S MXDATA(MXFILE,"?+1,"_DFN_",",MXFLD)=MXVAL K IEN D UPDATE^DIE("E","MXDATA","IEN","ERROR") Q:$G(DIERR) D
.. S RECORD=$G(IEN(1)),INC=$G(IEN(1,0))
.. S J=MX F S J=$O(MAR(J)) Q:'+J D
... s MXFILE=+$P(MAR(J),"(",2)
... S MXFLD=+$P(MAR(J),";",2)
... S MXVAL=$P(MAR(J),":",2),MXVAL=$S(MXVAL["(":$P(MXVAL,"("),1:MXVAL)
... S MXDATA(MXFILE,$S(MXFLD=.01:INC,1:"")_"1,"_RECORD_","_DFN_",",MXFLD)=MXVAL
... K IEN,ERROR D UPDATE^DIE("E","MXDATA","IEN","ERROR")
Q
;
DC(XDATE) ;Convert DOB to internal
N %DT,X
S X=XDATE,%DT="T" D ^%DT
Q Y
;
INSUR ;Insurance/Billing
Q
;
K S DA=$P(^DPT(0),"^",3),DIK="^DPT(" D ^DIK
S DIK="^AUPNPAT(" D ^DIK
Q
;

190
VWREGITT.m
View File

@ -1,190 +0,0 @@
VWREGITT ;Portland\Jim Bell, BFP,LLC Input Template Management 2016
;2.0**LOCAL** Copyright April 2016 ad infinitum;;;;;Build 2
;*****************************************************************
;* 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)! *
;*****************************************************************
;
Q ;No fall through
;
AUTH(TUSER,TNUM) ;Can user edit or is IT CONTROL
N TMO
S TMO=$O(^DIC(19,"B","VW REG IT CONTROL",0)) I $D(^VA(200,TUSER,203,"B",TMO)) Q 1
S TMO=$O(^DIC(19,"B","VW PATIENT REGISTRATION",0))
I TMO,$P(^DIE(TNUM,0),"^",5)=TUSER Q 1
Q 0
;
INR() Q $O(RESULT(" "),-1)+1
;
CF(FIELD) ;If a computed field, 0, else 1
I $P($G(^DD(2,FIELD,0)),"^",2)["C" Q 0
Q 1
;
EGF(RESULT,TNAME) ;Get fields for client editing via TName
;*************************
;* Incoming___TNAME(IEN) *
;*************************
K RESULT ;N TNUM,TNAME,PF,SF
S TNUM=+$P(TNAME,"(",2)
S TNAME=$P(TNAME,"(")
I 'TNUM!('$D(^DIE(TNUM))) S RESULT(0)="Template name or number not found in Template file" Q
;Check for authorization
I '$$AUTH(DUZ,TNUM) S RESULT(0)="Sorry, you are not authorized to edit this template." Q
S RESULT(0)="Editing "_TNAME_"("_TNUM_")"
S PF=$G(^DIE(TNUM,"DR",1,2))
F I=1:1:$L(PF,";") D:$P(PF,";",I)
. S RESULT($$INR)=$P(^DD(2,$P(PF,";",I),0),"^")_"("_$P(PF,";",I)_")"
. S SDD=+$P(^DD(2,$P(PF,";",I),0),"^",2) D:SDD
.. S SDN=1 F S SDN=$O(^DIE(TNUM,"DR",SDN)) Q:'SDN S:$O(^(SDN,0))=SDD SF=^(SDD) D
... F J=1:1:$L(SF,";") D:$P(SF,";",J)
.... S SFF=$P(^DIE(TNUM,"DR",SDN,SDD),";",J)
.... S RESULT($$INR)=" SF "_$P(^DD(SDD,SFF,0),"^")_"("_SFF_";"_SDD_")"
Q
;
SFLDS ;Get sub-fields and dics
K MULT N N,X,I,Y
S Y="",N=0 F S N=$O(TDATA(N)) Q:'+N D
. Q:TDATA(N)'[" SF" ;Still a major field
. F I=N:1:$O(TDATA(" "),-1) S X=TDATA(I) Q:X'[" SF" S MULT(+$P(X,";",2),+$P(X,"(",2))=""
Q
;
FIELDS() ;
N FLDLIST,N,X,FLD K MULT
S FLDLIST=""
S N=0 F S N=$O(TDATA(N)) Q:'+N D:TDATA(N)'[" SF"
. S FLD=+$P(TDATA(N),"(",2)
. Q:'$$CF(+$P(TDATA(N),"(",2)) ;Computed field
. S FLDLIST=FLDLIST_FLD_";"
;Collate thru for multiple fields:entry looks like " SF "
S N=0 F S N=$O(TDATA(N)) Q:'+N D:TDATA(N)[" SF"
. S X=$P(TDATA(N)," ",3)
. S SDD=+$P(X,";",2)
. S SFL=+$P(X,"(",2)
. S MULT(SDD,SFL)=""
S N=0 F S N=$O(MULT(N)) Q:'+N D S SUB(N)=MF
. S MF="",N2=0 F S N2=$O(MULT(N,N2)) Q:'+N2 S MF=MF_N2_";"
K MULT
Q FLDLIST
;
RTF(RESULT) ;Send a refresh of regit.txt to client
K AR,RESULT
D LTF
M RESULT=AR
K AR
Q
;
LTF ;Load the regit.txt file into AR()
S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
S FILE="regit.txt"
S P4=1
S P5=""
S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
Q
;
FTF ;File the AR() to regit.txt
ZSY "cp "_HD_"regit.txt "_HD_"regitbu.txt"
S P4=1,P5="",FILE="regit.txt"
S X=$$GTF^%ZISH($NA(AR(1)),1,HD,FILE)
Q
;
ITCNTRL(USER) ;Check for control capability and user authorization
N ITCNTRL
S ITCNTRL=$O(^DIC(19,"B","VW REG IT CONTROL",0))
I 'ITCNTRL D Q 0
. S VAL=0
. S RESULT(0)="-1^VW REGISTRATION does not appear to be complete."
. S RESULT(1)="Please contact your Supervisor or IT support."
. S RESULT(2)="Thank you,"
. S RESULT(3)="The Management"
I '$D(^VA(200,USER,203,"B",ITCNTRL)) D Q 0
. S RESULT(0)="-1^User does not have authorization to modify/create"
. S RESULT(1)="input templates. Please contact your Supervisor or"
. S RESULT(2)="IT support. Or, questions can be referred to Jim"
. S RESULT(3)="Bell at jbellco65@gmail.com"
. S RESULT(4)="Thank you."
Q 1
;
EN(RESULT,TDATA) ;
;************************************************
;* Call from Client *
;* TDATA Array: *
;* 0____Template Name^DUZ^ACTION^WRITEACCESS *
;* 1-n__Field name(number) *
;************************************************
; -- testing --
;M ^DIZ("TDATA",$J)=TDATA
;Q
; -- end testing --
;
N TNAME,TNUM,ITCNTRL,ACTION,FIELDS,CALLER
S CALLER=""
S X="TDATA" F S X=$Q(@X) Q:X="" S @X=$$UP^XLFSTR(@X) ;Upcase everyTHING
I '$L($G(HD)) S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
S WHO=$P(TDATA(0),"^",2)
S ITCNTRL=$$ITCNTRL(WHO) ;1=full action;0=create/edit own template(s)
S TNUM=+$P($P(TDATA(0),"^"),"(",2)
S TNAME=$P($P(TDATA(0),"^"),"(")
I TNAME["Editing" S SPEC("Editing ")="",TNAME=$$REPLACE^XLFSTR(TNAME,.SPEC)
S ACTION=$P(TDATA(0),"^",3)
S WRITEACC=$S($P(TDATA(0),"^",4)="SELF":$P(^VA(200,DUZ,0),"^",4),1:"")
S FIELDS=$$FIELDS
I '$L(ACTION) S RESULT(0)="-1^No action sent. I don't know what to do." Q
D @ACTION
Q
;
CREATE ;Create a new input template
;******************************
;* Check for computed fields *
;******************************
K RESULT N %DT,X,Y
S %DT="TS",X="NOW" D ^%DT S FDATE=Y
S X=TNAME,DIC="^DIE(",DIC(0)="LZ" D FILE^DICN
S $P(^DIE(+Y,0),"^",2)=FDATE,$P(^(0),"^",3)="",$P(^(0),"^",4)=2,$P(^(0),"^",5)=DUZ
S $P(^DIE(+Y,0),"^",6)=WRITEACC
C2 S ^DIE(+Y,"DR",1,2)=FIELDS
;Do mult fields here
S N=0 F S N=$O(SUB(N)) Q:'+N D
. S UP=^DD(N,0,"UP")
. I UP=2 S ^DIE(+Y,"DR",$O(^DIE(+Y,"DR"," "),-1)+1,N)=SUB(N)
. E S ^DIE(+Y,"DR",$O(^DIE(+Y,"DR"," "),-1),N)=SUB(N)
I $P(^DIE(+Y,0),"^")=$P(TDATA(0),"^") S RESULT(0)=$P(Y,"^",2)_" filed"
Q:CALLER="EDIT"
S TNUM=+Y,TNAME=$P(Y,"^",2)
K AR
D LTF ;Get the regit.txt file loaded into AR()
S LAST=$O(AR(" "),-1)
S AR(LAST)=TNAME_"("_TNUM_")"
S AR(LAST+1)="[ID]"
;M ^DIZ("TDATA","AR",$J)=AR ;Testing
D FTF ;File AR() to regit.txt
K ^DIZ("TDATA",$J)
Q
;
EDIT ;Edit existing. Check for allowability
S Y=TNUM_"^"_TNAME
EL L -^DIE(TNUM):1 G EL:'$T
S S=1 F S S=$O(^DIE(TNUM,"DR",S)) Q:'+S D
. S SUBD=0 F S SUBD=$O(^DIE(TNUM,"DR",S,SUBD)) Q:'+SUBD K ^DIE(TNUM,"DR",S,SUBD)
S CALLER="EDIT"
D C2
L +^DIE(TNUM)
S DA=TNUM,DIK="^DIE(" D IX^DIK ;Re-index record just in case...
S RESULT(0)=Y_" modification filed..."
Q
;
DELETE ;********************************************
;* 1. Get the regit.txt contents into AR() *
;* 2. Remove the template from the list *
;* 3. Refile regit.txt *
;********************************************
K AR
M AR=RESULT
K AR(0) ;ID string for EN
D FTF
I X S RESULT(0)="Template menu list updated."
E S RESULT(0)="Template list not updated. Advise Template manager to manually update "_HD_"regit.txt"
Q

160
VWREGITU.m
View File

@ -1,160 +0,0 @@
VWREGITU ;Portland, OR/jeb et al World Vista Registration Utilities
;V.2;;**LOCAL**;; 2015;Build 2
;;c2014, BellFelder Productions(BF Productions)
;No Fall thru - jeb
Q
;
DFNID() ;Set NAME(IEN),TAB,DOB(AGE),TAB,HRN,TAB,PHONE#
N DFNID,NAME,X,Y,DOB,HRN,PHONE
I 'DFN Q ""
S NAME=$P(^DPT(DFN,0),"^")
S Y=$$OUTPUT^VWTIME(DFN) X ^DD("DD") S DOB=Y
S HRN=$G(^DPT(DFN,540001.1))
S PHONE="Phone: "_$P(^DPT(DFN,.13),"^")
S DFNID=NAME_$C(9)_DOB_$C(9)_$S($L(HRN):"HRN: "_HRN_$C(9),1:"")_PHONE
Q DFNID
;
HELP(XDIC,XFIELD) ;
N N
K FHELP
S FHELP=$G(^DD(XDIC,XFIELD,3))
G:'$L(FHELP) HELPX
S FHELP=FHELP_$S($E($L(FHELP))=".":" ",1:". ")
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)_" "
S FHELP=$TR(FHELP,"'","`")
HELPX Q FHELP
;
M(RESULT,XMF) ;
; **********************************************
; * XMF_____PARENT FIELD^DFN^TEMPLATE NAME(IEN)*
; **********************************************
;
;W " ;Intentional break
K RESULT,AR,TEMPLATE
N XMFD,SUBD,SUBD3,SUBD4,SUBD5,F2,F3,F4,F5,DFN,N,X,SUBF,XT,FHELP
S TNUM=+$P(XMF,"(",2) ;Template IEN, if any
S DFN=+$P(XMF,"^",2) ;Client IEN, if any
S XMF=+XMF ;Parent field
I '+$P(^DD(2,XMF,0),"^",2) S RESULT(0)=-1 ;Not a parent, eh?!
S XMFD=+$P(^(0),"^",2)
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)
. S SUBD=+$P(^(0),"^",2)
. 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)
.. S SUBD3=+$P(^(0),"^",2)
.. 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)
... S SUBD4=+$P(^DD(SUBD3,F3,0),"^",2)
... 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)
.... S SUBD5=+$P(^(0),"^",2)
.... 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)
;Clean up of parents IN multiple fields
M AR=RESULT K RESULT N DD,F
S N=0 F S N=$O(AR(N)) Q:'+N D
. S DD=+$P($P(AR(N),"^",2),";") ;Is this a sub DD ?
. S F=+$P(AR(N),";",2)
. I +$P(^DD(DD,F,0),"^",2) K AR(N)
;Clean up fields not in template
M TEMPLATE=^DIE(TNUM,"DR")
S X=$Q(@"TEMPLATE") K @X ;Remove top, non-multiple subscript
S X="AR" F S X=$Q(@X) Q:X="" D
. S SUBD=+$P($P(@X,"^",2),";")
. S SUBF=+$P(@X,";",2)
. F I=1:1:20 I $D(TEMPLATE(I,SUBD)) D
.. Q:TEMPLATE(I,SUBD)[SUBF
.. K @X
S N=0 F S N=$O(AR(N)) Q:'+N S RESULT($$INR)=AR(N)
K AR,TEMPLATE
Q
;
DISV(RESULT,DFN) ;Set the Disv GLOBAL
K RESULT
I '$L(DFN) S RESULT=-1 Q
S ^DISV(DUZ,"^DPT(")=+$P(DFN,"(",2),RESULT=1
Q
;
SR(FNAME,FNUM,FVALUE,FHELP,FSETPNTR,FMISC) ;Set values into RESULT()
;********************************************************
;* FNAME________Field Name *
;* FNUM_________Field Number *
;* FVALUE_______Data from existing client/patient *
;* FHELP________Help text from field *
;* FSETPNTR_____Set of codes or Pointer reference *
;* FMISC________Locally described designator (not used) *
;********************************************************
S RESULT($$INR)=FNAME_"^"_FNUM_"^"_FVALUE_"^"_FHELP_"^"_FSETPNTR_"^"_FMISC
Q
;
INR() ;Specific incrementer for RESULT array
Q $O(RESULT(" "),-1)+1
;
ZPC(RESULT,ZIP) ;Get zip,county/area/region,state/province,preferred city
K RESULT N STP,CNTP,COUNTY,XZIP
S XZIP=ZIP S RESULT(0)="No return" Q:'$L(XZIP)
D POSTAL^XIPUTIL(XZIP,.ZIPDATA)
I $D(ZIPDATA("ERROR")) Q ;Can't be found
S COUNTY=$G(ZIPDATA("COUNTY"))
S STP=$G(ZIPDATA("STATE POINTER"))
I STP,$L(COUNTY) S CNTP=$O(^DIC(5,STP,1,"B",COUNTY,0))
K RESULT(0)
S RESULT($$INR)=ZIPDATA("STATE")_"("_STP_")"
S RESULT($$INR)=ZIPDATA("COUNTY")_"("_CNTP_")"
S RESULT($$INR)=ZIPDATA("CITY")
S RESULT($$INR)=ZIPDATA("FIPS CODE")
K ZIPDATA
Q
;
SPI(RESULT,DFN) ;Simple patient inquiry display
S LINE="----------"
S DIC="^DPT(",DA=DFN,DIQ(0)="E",DIQ="AR"
S DR=".01:.05;.111:.115;.1171:.1173;.117;.363"
D EN^DIQ1
S CITY=$G(AR(2,DFN,.114,"E"))
S STIEN="",STATE=$G(AR(2,DFN,.115,"E")) S:$L(STATE) STIEN=$O(^DIC(5,"B",STATE,0))
S XAGE=$G(AR(2,DFN,.033,"E"))
S XAGE=$S(+XAGE:XAGE_" y/o",1:"")
;;GET HRN
HRN S HRN="",N=$O(^AUPNPAT(DFN,41,0))
S HRN=$S('N:HRN,1:$P($G(^AUPNPAT(DFN,41,N,0)),"^",2))
S RESULT($$INR)=AR(2,DFN,.01,"E")_" "_AR(2,DFN,.363,"E")_" HRN: "_HRN
S RESULT($$INR)="DOB: "_AR(2,DFN,.03,"E")_" ("_XAGE_" "_AR(2,DFN,.02,"E")_")"
S RESULT($$INR)="ADDRESS"_LINE_LINE
S RESULT($$INR)=$G(AR(2,DFN,.111,"E"))_" "_$G(AR(2,DFN,.112,"E"))
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")))
S RESULT($$INR)="Walk-ins"_LINE_LINE
S RESULT($$INR)="Appointments"_LINE_LINE
S RESULT($$INR)="Admissions"_LINE_LINE
Q
;
CONTROL() ;Check for CONTROL status
N X S X=$O(^DIC(19,"B","VW REG IT CONTROL",0))
I 'X Q 0 ;Ain't no option there
Q $S($D(^VA(200,DUZ,203,"B",X)):1,1:0)
;
MISC(RESULT,VWDD) ;Get simple value from VWDD ID
;***************************************************
;* VWDD___________________(sub)-Dictionary number *
;* Multiple delimiter_____;(Semicolon) *
;***************************************************
;
I '$L(VWDD) S RESULT(0)="No value to evaluate" Q
K RESULT
N XDD,XDDLOC,N,X
G MISCSD:$G(^DD(VWDD,0,"UP"))
S CALLER=$S($P(VWDD,"^",2)="INS":1,1:0)
S VWDD=$P(VWDD,"^")
F I=1:1:$L(VWDD,";") S XDD=+$P(VWDD,";",I) S RESULT($$INR)="["_$P(^DIC(XDD,0),"^")_"]" D MISC1
I CALLER S RESULT($$INR)="[GUARANTOR]" D
. S X=$P(^DD(2.312,16,0),"^",3)
. F I=1:1:$L(X,";") S Y=$P(X,";",I),RESULT($$INR)=$P(Y,":",2)_"("_$P(Y,":")_")"
Q
;
MISC1 S XDDLOC=$G(^DIC(XDD,0,"GL")) D:$L(XDDLOC)
. S N=0 F S N=$O(@(XDDLOC_N_")")) Q:'+N D
.. I XDDLOC["779.004" S XCNAME=$P(@(XDDLOC_N_",0)"),"^")_" "_$P(^(0),"^",2)_" "_+$G(^("SDS"))_"("_N_")",RESULT($$INR)=XCNAME Q
.. S X=$P(@(XDDLOC_N_",0)"),"^")_"("_N_")",RESULT($$INR)=X
MX Q
;
MISCSD ;Sub-dictionary
W ^("UP")
Q
;

326
VWREGITX.m
View File

@ -1,326 +0,0 @@
VWREGITX ;VWEHR/BFProd-Jim Bell, et al - World VistA GUI Pat Reg Utility
;;;;;;Build 2
;;1.0;WORLD VISTA;**LOCAL **;;Build 26
;
;This routine utility is for patient specific fields and
;is used to build input templates for registration
;
;GNU License: See WVLIC.txt
;Modified FOIA VISTA,
;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
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
;