From 7eabd8c1a4ae20af40d4aa9a12cf87dccc95d871 Mon Sep 17 00:00:00 2001 From: jbell Date: Wed, 8 Mar 2017 22:10:56 +0000 Subject: [PATCH] --- VWREGIT.m | 162 -------------------------- VWREGIT2.m | 61 ---------- VWREGIT3.m | 11 -- VWREGITP.m | 57 ---------- VWREGITS.m | 115 ------------------- VWREGITT.m | 190 ------------------------------- VWREGITU.m | 160 -------------------------- VWREGITX.m | 326 ----------------------------------------------------- 8 files changed, 1082 deletions(-) delete mode 100644 VWREGIT.m delete mode 100644 VWREGIT2.m delete mode 100644 VWREGIT3.m delete mode 100644 VWREGITP.m delete mode 100644 VWREGITS.m delete mode 100644 VWREGITT.m delete mode 100644 VWREGITU.m delete mode 100644 VWREGITX.m diff --git a/VWREGIT.m b/VWREGIT.m deleted file mode 100644 index 2d2ff04..0000000 --- a/VWREGIT.m +++ /dev/null @@ -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 - ; - diff --git a/VWREGIT2.m b/VWREGIT2.m deleted file mode 100644 index f3c87ee..0000000 --- a/VWREGIT2.m +++ /dev/null @@ -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 - ; diff --git a/VWREGIT3.m b/VWREGIT3.m deleted file mode 100644 index 85bdae1..0000000 --- a/VWREGIT3.m +++ /dev/null @@ -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 - ; diff --git a/VWREGITP.m b/VWREGITP.m deleted file mode 100644 index 7531c02..0000000 --- a/VWREGITP.m +++ /dev/null @@ -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 diff --git a/VWREGITS.m b/VWREGITS.m deleted file mode 100644 index 754098e..0000000 --- a/VWREGITS.m +++ /dev/null @@ -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 - ; diff --git a/VWREGITT.m b/VWREGITT.m deleted file mode 100644 index 1372d29..0000000 --- a/VWREGITT.m +++ /dev/null @@ -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 - diff --git a/VWREGITU.m b/VWREGITU.m deleted file mode 100644 index fb98c1a..0000000 --- a/VWREGITU.m +++ /dev/null @@ -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 - ; - diff --git a/VWREGITX.m b/VWREGITX.m deleted file mode 100644 index c3b1fab..0000000 --- a/VWREGITX.m +++ /dev/null @@ -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:"") - . 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:"") - . 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:"") - . 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:"") - . 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:"") - 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:"") - . 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 - ; -