Index: /GUIRegistration/tag/1.0/METHelp.html =================================================================== --- /GUIRegistration/tag/1.0/METHelp.html (revision 1635) +++ /GUIRegistration/tag/1.0/METHelp.html (revision 1635) @@ -0,0 +1,124 @@ + + + + Make and/or Editing Input Templates + + + + + + + + + + + + + +
+ +
+Making or Editing Input Templates for Patient Data Collection +

+
+Recommended Reading: The Fileman Manual at Hardhats.org +Fileman for all Fileman related usage.

+Explanation: This is a graphical access to the Fileman Input Template process. +Because this is oriented to Patient/Client Registration, it is strictly tied to the Patient file. +As noted by the logo at the top of this page, the database manager, Fileman, provides the filing of +your work. One note on Fileman's capability: There are fields that can hold multiple values +and sub-fields of information. An example of this is the Alias multiple field: + +Here is a test patient, Mortimer Snerd and his alias(es): + + + + + + + + + + + + + + +
PATIENT LIST
ALIASALIAS SSN
SNERD,MORTY000001111
QUACKENBUSH,EBENEEZER U000001112
+
+Multiple fields are identified by the parent field followed by the term (multiple) with +children of the parent shown as >>>>>>field name. +

+Editing or Making a New Template:
+ + +

+
Full screen width display
+

+ +Process: +
    +
  1. Highlight a template in one of the template listing areas,
    2. +
  2. Or not, and Press the "Make" button,
    3. +
  3. Enter a name for your template, if one was not selected,
    4. +
  4. Transfer data from the listing above to your memo: +
      +
    • Select the fields you want transferred by highlighting either + individually, range of fields (CLK-Drag or SHFT-Clk), or multiple individual + fields (CTRL-Clk).
      • +
    • RIGHT-CLK will automatically move the field(s) to the memo area.
      • +
    • To help target sets of fields, use the Find feature at the top of form
      • +
        +
      • For example, if you wanted to find address fields for your template, + You could enter STREET,CITY,STATE,POSTAL,ZIP,COUNTY, and press the "Go" + button. A Separate pop-up will list all those fields in the patient + file that contained that text. Then use the SHFT-Click (range) or CTRL- + click (individual selections), and press the ok. Those fields will be + appended to the template memo area for any further editing.
        • +
      +
    +
  5. When satisfied with your work, press the "Save" button and the following + should happen:
    6. +
      +
    1. The template is saved on the M server system via Fileman
      2. +
    2. The regit.txt listing file at the home directory will be updated
      3. +
    3. The "Templates in regit.txt" listing on this window will be updated
      4. +
    4. The combo template list on the main window will be updated
      5. +
    5. The template will be available for selection.
      6. +
    +
+
+ + + + Index: /GUIRegistration/tag/1.0/VWGUIREG_UPDATE_03232014.KID =================================================================== --- /GUIRegistration/tag/1.0/VWGUIREG_UPDATE_03232014.KID (revision 1635) +++ /GUIRegistration/tag/1.0/VWGUIREG_UPDATE_03232014.KID (revision 1635) @@ -0,0 +1,2082 @@ +KIDS Distribution saved on Mar 23, 2014@10:18:31 +World VistA +**KIDS**:VWGUIR_UPDATE_03232014*1.0T*1^ + +**INSTALL NAME** +VWGUIR_UPDATE_03232014*1.0T*1 +"BLD",8495,0) +VWGUIR_UPDATE_03232014*1.0T*1^^0^3140323^n +"BLD",8495,1,0) +^^2^2^3140323^ +"BLD",8495,1,1,0) +Contains routine updates, pat inquiry display, enables making an +"BLD",8495,1,2,0) +input template through the GUI. +"BLD",8495,4,0) +^9.64PA^^ +"BLD",8495,6.3) +1 +"BLD",8495,"KRN",0) +^9.67PA^779.2^20 +"BLD",8495,"KRN",.4,0) +.4 +"BLD",8495,"KRN",.401,0) +.401 +"BLD",8495,"KRN",.402,0) +.402 +"BLD",8495,"KRN",.402,"NM",0) +^9.68A^^0 +"BLD",8495,"KRN",.403,0) +.403 +"BLD",8495,"KRN",.5,0) +.5 +"BLD",8495,"KRN",.84,0) +.84 +"BLD",8495,"KRN",3.6,0) +3.6 +"BLD",8495,"KRN",3.8,0) +3.8 +"BLD",8495,"KRN",3.8,"NM",0) +^9.68A^^0 +"BLD",8495,"KRN",9.2,0) +9.2 +"BLD",8495,"KRN",9.8,0) +9.8 +"BLD",8495,"KRN",9.8,"NM",0) +^9.68A^11^4 +"BLD",8495,"KRN",9.8,"NM",8,0) +VWREGIT^^0^B129809193 +"BLD",8495,"KRN",9.8,"NM",9,0) +VWREGIT2^^0^B100003944 +"BLD",8495,"KRN",9.8,"NM",10,0) +VWREGIT3^^0^B43452100 +"BLD",8495,"KRN",9.8,"NM",11,0) +VWREGIT4^^0^B43791810 +"BLD",8495,"KRN",9.8,"NM","B","VWREGIT",8) + +"BLD",8495,"KRN",9.8,"NM","B","VWREGIT2",9) + +"BLD",8495,"KRN",9.8,"NM","B","VWREGIT3",10) + +"BLD",8495,"KRN",9.8,"NM","B","VWREGIT4",11) + +"BLD",8495,"KRN",19,0) +19 +"BLD",8495,"KRN",19,"NM",0) +^9.68A^^0 +"BLD",8495,"KRN",19.1,0) +19.1 +"BLD",8495,"KRN",101,0) +101 +"BLD",8495,"KRN",101,"NM",0) +^9.68A^^0 +"BLD",8495,"KRN",409.61,0) +409.61 +"BLD",8495,"KRN",771,0) +771 +"BLD",8495,"KRN",771,"NM",0) +^9.68A^^0 +"BLD",8495,"KRN",779.2,0) +779.2 +"BLD",8495,"KRN",870,0) +870 +"BLD",8495,"KRN",8989.51,0) +8989.51 +"BLD",8495,"KRN",8989.51,"NM",0) +^9.68A^^0 +"BLD",8495,"KRN",8989.52,0) +8989.52 +"BLD",8495,"KRN",8994,0) +8994 +"BLD",8495,"KRN",8994,"NM",0) +^9.68A^10^1 +"BLD",8495,"KRN",8994,"NM",10,0) +VW REG PATINQ^^0 +"BLD",8495,"KRN",8994,"NM","B","VW REG PATINQ",10) + +"BLD",8495,"KRN","B",.4,.4) + +"BLD",8495,"KRN","B",.401,.401) + +"BLD",8495,"KRN","B",.402,.402) + +"BLD",8495,"KRN","B",.403,.403) + +"BLD",8495,"KRN","B",.5,.5) + +"BLD",8495,"KRN","B",.84,.84) + +"BLD",8495,"KRN","B",3.6,3.6) + +"BLD",8495,"KRN","B",3.8,3.8) + +"BLD",8495,"KRN","B",9.2,9.2) + +"BLD",8495,"KRN","B",9.8,9.8) + +"BLD",8495,"KRN","B",19,19) + +"BLD",8495,"KRN","B",19.1,19.1) + +"BLD",8495,"KRN","B",101,101) + +"BLD",8495,"KRN","B",409.61,409.61) + +"BLD",8495,"KRN","B",771,771) + +"BLD",8495,"KRN","B",779.2,779.2) + +"BLD",8495,"KRN","B",870,870) + +"BLD",8495,"KRN","B",8989.51,8989.51) + +"BLD",8495,"KRN","B",8989.52,8989.52) + +"BLD",8495,"KRN","B",8994,8994) + +"BLD",8495,"QDEF") +^^^^NO^^^^NO^^NO +"BLD",8495,"QUES",0) +^9.62^^ +"BLD",8495,"REQB",0) +^9.611^^ +"KRN",8994,2596,-1) +0^10 +"KRN",8994,2596,0) +VW REG PATINQ^DEMOG^VWREGIT4^2^P^^^0^1 +"KRN",8994,2596,1,0) +^8994.01^1^1^3140313^^ +"KRN",8994,2596,1,1,0) +Returns all existing demographic (non-clinical) data on a patient +"KRN",8994,2596,2,0) +^8994.02A^1^1 +"KRN",8994,2596,2,1,0) +IDATA^1^^1^1 +"KRN",8994,2596,2,"B","IDATA",1) + +"KRN",8994,2596,2,"PARAMSEQ",1,1) + +"MBREQ") +0 +"ORD",16,8994) +8994;16;1;;;;;;;RPCDEL^XPDIA1 +"ORD",16,8994,0) +REMOTE PROCEDURE +"QUES","XPF1",0) +Y +"QUES","XPF1","??") +^D REP^XPDH +"QUES","XPF1","A") +Shall I write over your |FLAG| File +"QUES","XPF1","B") +YES +"QUES","XPF1","M") +D XPF1^XPDIQ +"QUES","XPF2",0) +Y +"QUES","XPF2","??") +^D DTA^XPDH +"QUES","XPF2","A") +Want my data |FLAG| yours +"QUES","XPF2","B") +YES +"QUES","XPF2","M") +D XPF2^XPDIQ +"QUES","XPI1",0) +YO +"QUES","XPI1","??") +^D INHIBIT^XPDH +"QUES","XPI1","A") +Want KIDS to INHIBIT LOGONs during the install +"QUES","XPI1","B") +NO +"QUES","XPI1","M") +D XPI1^XPDIQ +"QUES","XPM1",0) +PO^VA(200,:EM +"QUES","XPM1","??") +^D MG^XPDH +"QUES","XPM1","A") +Enter the Coordinator for Mail Group '|FLAG|' +"QUES","XPM1","B") + +"QUES","XPM1","M") +D XPM1^XPDIQ +"QUES","XPO1",0) +Y +"QUES","XPO1","??") +^D MENU^XPDH +"QUES","XPO1","A") +Want KIDS to Rebuild Menu Trees Upon Completion of Install +"QUES","XPO1","B") +NO +"QUES","XPO1","M") +D XPO1^XPDIQ +"QUES","XPZ1",0) +Y +"QUES","XPZ1","??") +^D OPT^XPDH +"QUES","XPZ1","A") +Want to DISABLE Scheduled Options, Menu Options, and Protocols +"QUES","XPZ1","B") +NO +"QUES","XPZ1","M") +D XPZ1^XPDIQ +"QUES","XPZ2",0) +Y +"QUES","XPZ2","??") +^D RTN^XPDH +"QUES","XPZ2","A") +Want to MOVE routines to other CPUs +"QUES","XPZ2","B") +NO +"QUES","XPZ2","M") +D XPZ2^XPDIQ +"RTN") +4 +"RTN","VWREGIT") +0^8^B129809193 +"RTN","VWREGIT",1,0) +VWREGIT ;VWEHR/BFProd - Jim Bell, et al... - World VistA Patient Registration Utility +"RTN","VWREGIT",2,0) + ;;1.0;WORLD VISTA;** **;;Build 1 +"RTN","VWREGIT",3,0) + ; +"RTN","VWREGIT",4,0) + ;This routine utility is for Patient specific fields and +"RTN","VWREGIT",5,0) + ; calls a Fileman input template. +"RTN","VWREGIT",6,0) + ; +"RTN","VWREGIT",7,0) + ;GNU License: See WVLIC.txt +"RTN","VWREGIT",8,0) + ;Modified FOIA VISTA, +"RTN","VWREGIT",9,0) + ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU +"RTN","VWREGIT",10,0) + Q +"RTN","VWREGIT",11,0) + ; +"RTN","VWREGIT",12,0) + ;S IDSTR="REG(1733)^^L^^" +"RTN","VWREGIT",13,0) + ; +"RTN","VWREGIT",14,0) +MV(PAT,SUBD,FLDS) ;Get the listing of multiple values in external format +"RTN","VWREGIT",15,0) + S VAL="" +"RTN","VWREGIT",16,0) + Q +"RTN","VWREGIT",17,0) + ; +"RTN","VWREGIT",18,0) +GDOBT(PATIENT) ;Get date of birth with time +"RTN","VWREGIT",19,0) + N DOB,Y +"RTN","VWREGIT",20,0) + S Y=$P(^DPT(PATIENT,0),"^",3)+$G(^DPT(PATIENT,540000)) +"RTN","VWREGIT",21,0) + X ^DD("DD") +"RTN","VWREGIT",22,0) + Q Y +"RTN","VWREGIT",23,0) + ; +"RTN","VWREGIT",24,0) +MM ;Mis-match IDs belong to someone other than client input +"RTN","VWREGIT",25,0) + S RESULT(0)="MM^-1" +"RTN","VWREGIT",26,0) + S RESULT(1)="ID belongs to "_ARR("DILIST",1,1) +"RTN","VWREGIT",27,0) + Q +"RTN","VWREGIT",28,0) + ; +"RTN","VWREGIT",29,0) +FIELDS ;Get field numbers/labels/titles at ^DIE(TNUM... +"RTN","VWREGIT",30,0) + K XR +"RTN","VWREGIT",31,0) + S RESULT($$INR)="[FLDS]" +"RTN","VWREGIT",32,0) + S FSET=$G(^DIE(TNUM,"DR",1,2)) +"RTN","VWREGIT",33,0) + S C=0 ;Keep order of template +"RTN","VWREGIT",34,0) + F I=1:1:$L(FSET,";")-1 D +"RTN","VWREGIT",35,0) + . S MF=+$P(^DD(XFILE,+$P(FSET,";",I),0),"^",2) +"RTN","VWREGIT",36,0) + . D:MF +"RTN","VWREGIT",37,0) + .. S MFS=$G(^DIE(TNUM,"DR",2,MF)) +"RTN","VWREGIT",38,0) + .. I $L(MFS) F J=1:1:$L(MFS,";")-1 D +"RTN","VWREGIT",39,0) + ... S C=C+1 +"RTN","VWREGIT",40,0) + ... S XR(C,MF,+$P(MFS,";",J))=$P(^DD(MF,+$P(MFS,";",J),0),"^")_"^"_MF_";"_+$P(MFS,";",J)_"^^^" +"RTN","VWREGIT",41,0) + ... I $P(^DD(MF,+$P(MFS,";",J),0),"^",2)["P" S $P(XR(C,MF,+$P(MFS,";",J)),"^",5)=$P(^DD(MF,+$P(MFS,";",J),0),"^",3) +"RTN","VWREGIT",42,0) + . Q:MF +"RTN","VWREGIT",43,0) + . S C=C+1,XR(C,+$P(FSET,";",I))=$P(^DD(XFILE,+$P(FSET,";",I),0),"^")_"^"_+$P(FSET,";",I)_"^^"_$$HINT(XFILE,+$P(FSET,";",I))_"^"_$P(^DD(XFILE,+$P(FSET,";",I),0),"^",3) +"RTN","VWREGIT",44,0) + S X="XR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X +"RTN","VWREGIT",45,0) + ;For county help listing until DB is fixed /jeb 9/15/2013 @ 08:43 +"RTN","VWREGIT",46,0) + S N=0 F S N=$O(RESULT(N)) Q:'+N I $P(RESULT(N),"^",2)=.117 S $P(RESULT(N),"^",5)="VIC(5.1," +"RTN","VWREGIT",47,0) + K XR +"RTN","VWREGIT",48,0) + S DIET=TNUM D GET^DIETED("AR"),PREFLAB^VWREGIT3 +"RTN","VWREGIT",49,0) + Q +"RTN","VWREGIT",50,0) + ; +"RTN","VWREGIT",51,0) +GETTD(RESULT,XDESC) ;Get template description +"RTN","VWREGIT",52,0) + K RESULT +"RTN","VWREGIT",53,0) + N N,TNUM +"RTN","VWREGIT",54,0) + S TNUM=+$P(XDESC,"(",2) +"RTN","VWREGIT",55,0) + I '$O(^DIE(TNUM,"%D",0)) S RESULT(0)="No description on file" Q +"RTN","VWREGIT",56,0) + S N=0 F S N=$O(^DIE(TNUM,"%D",N)) Q:'+N S RESULT($$INR)=^(N,0) +"RTN","VWREGIT",57,0) + Q +"RTN","VWREGIT",58,0) + ; +"RTN","VWREGIT",59,0) +ME(X) ;mail to group +"RTN","VWREGIT",60,0) + S GROUP=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0)) +"RTN","VWREGIT",61,0) + S TITLE=X +"RTN","VWREGIT",62,0) + S INFO=1 +"RTN","VWREGIT",63,0) + S FM=DUZ +"RTN","VWREGIT",64,0) + D MSG^BFPMAIL +"RTN","VWREGIT",65,0) + Q +"RTN","VWREGIT",66,0) + ; +"RTN","VWREGIT",67,0) +COUNTY ;Special listing for county (re: Saturday 9/14/2013 WV discussion) +"RTN","VWREGIT",68,0) + K RESULT,XR +"RTN","VWREGIT",69,0) + S RESULT(0)=0 +"RTN","VWREGIT",70,0) + S PFILE="^"_PFILE +"RTN","VWREGIT",71,0) + S N=0 F S N=$O(@(PFILE_N_")")) Q:'+N S X=^(N,0) D +"RTN","VWREGIT",72,0) + . S STATE=$P(X,"^",2) +"RTN","VWREGIT",73,0) + . S COUNTY=$P(X,"^") +"RTN","VWREGIT",74,0) + . S STATE=$P($G(^DIC(5,STATE,0)),"^") +"RTN","VWREGIT",75,0) + . S STATE=$S(STATE="":"UNKNOWN",1:STATE) +"RTN","VWREGIT",76,0) + . S XR(STATE,COUNTY)=COUNTY_"~"_STATE +"RTN","VWREGIT",77,0) + S X="XR" F S X=$Q(@X) Q:X="" S Y=@X,RESULT($$INR)=Y +"RTN","VWREGIT",78,0) + S RESULT(0)=$O(RESULT(" "),-1)_" Items:" +"RTN","VWREGIT",79,0) + K XR +"RTN","VWREGIT",80,0) + Q +"RTN","VWREGIT",81,0) + ; +"RTN","VWREGIT",82,0) +PSF(RESULT,XLINE) ;Pointer/Set of Codes values +"RTN","VWREGIT",83,0) + ;W " ;Intentionally "instantiated" hard failure - jeb +"RTN","VWREGIT",84,0) + K RESULT +"RTN","VWREGIT",85,0) + N XFILE,XFIELD,XDATA,XIT,PFILE +"RTN","VWREGIT",86,0) + S RESULT(0)=0 +"RTN","VWREGIT",87,0) + S DFN=$P(XLINE,"^",7) +"RTN","VWREGIT",88,0) + S PFILE=$P(XLINE,"^",6) ;POINTED TO FILE +"RTN","VWREGIT",89,0) + I PFILE="VIC(5.1," D COUNTY Q ;Work around until DB is fixed /jeb 9/15/2013 +"RTN","VWREGIT",90,0) + S XIT=+$P(XLINE,"(",2) Q:'XIT +"RTN","VWREGIT",91,0) + S XFILE=$S($P(XLINE,"^",3)[";":$P($P(XLINE,"^",3),";"),1:$P(^DIE(XIT,0),"^",4)) +"RTN","VWREGIT",92,0) + S XFIELD=$S($P(XLINE,"^",3)[";":$P($P(XLINE,"^",3),";",2),1:$P(XLINE,"^",3)) +"RTN","VWREGIT",93,0) + S XFIELD=$S($L(XFIELD):XFIELD,1:+$P(XLINE,"^",3)) Q:'XFIELD +"RTN","VWREGIT",94,0) + Q:$P(^DD(XFILE,XFIELD,0),"^",2)'["S"&($P(^DD(XFILE,XFIELD,0),"^",2)'["P") +"RTN","VWREGIT",95,0) + I $P(^DD(XFILE,XFIELD,0),"^",2)["S" D S RESULT(0)=$O(RESULT(" "),-1) Q +"RTN","VWREGIT",96,0) + . S XDATA=$P(^(0),"^",3) +"RTN","VWREGIT",97,0) + . S XDATA=$E(XDATA,1,$L(XDATA)-1) +"RTN","VWREGIT",98,0) + . F I=1:1:$L(XDATA,";") S RESULT($$INR)=$P($P(XDATA,";",I),":",2) +"RTN","VWREGIT",99,0) + Q:'$L(PFILE) ;No pointer to reference +"RTN","VWREGIT",100,0) + S PFILE="^"_PFILE +"RTN","VWREGIT",101,0) + S N=0 F S N=$O(@(PFILE_N_")")) Q:'+N S RESULT($$INR)=$S(PFILE[779.004:$P(^(N,0),"^")_"~"_$P(^(0),"^",2),1:$P(^(N,0),"^")) +"RTN","VWREGIT",102,0) + S RESULT(0)=$O(RESULT(" "),-1)_" Items:" +"RTN","VWREGIT",103,0) + Q +"RTN","VWREGIT",104,0) + ; +"RTN","VWREGIT",105,0) +HINT(FILE,FLD) ; +"RTN","VWREGIT",106,0) + N X,N,Y +"RTN","VWREGIT",107,0) + Q:'$L(FLD) ;...hmmmm... +"RTN","VWREGIT",108,0) + S X="",N=0 F S N=$O(^DD(FILE,FLD,21,N)) Q:'+N D +"RTN","VWREGIT",109,0) + . S Y=$G(^DD(FILE,FLD,21,N,0))_$S($O(^DD(FILE,FLD,21,N)):" ",1:"") +"RTN","VWREGIT",110,0) + . S X=X_$TR(Y,"'","") +"RTN","VWREGIT",111,0) + I X="" S X="" +"RTN","VWREGIT",112,0) + Q X +"RTN","VWREGIT",113,0) + ; +"RTN","VWREGIT",114,0) +GETMULTS(MN) ; +"RTN","VWREGIT",115,0) + Q:'MN +"RTN","VWREGIT",116,0) + F I=1:1:$L(FSETM(MN),";")-1 D +"RTN","VWREGIT",117,0) + . S MNF=$P(FSETM(MN),";",I) +"RTN","VWREGIT",118,0) + . S RESULT($$INR)=$P(^DD(MN,MNF,0),"^")_"^"_MN_";"_MNF +"RTN","VWREGIT",119,0) + Q +"RTN","VWREGIT",120,0) + ; +"RTN","VWREGIT",121,0) +VPAR(SUBD) ; +"RTN","VWREGIT",122,0) + N X +"RTN","VWREGIT",123,0) + S X="" +"RTN","VWREGIT",124,0) + I $D(PAR(SUBD)) S X=@$Q(PAR(SUBD)) +"RTN","VWREGIT",125,0) + Q X +"RTN","VWREGIT",126,0) + ; +"RTN","VWREGIT",127,0) +INC(C) Q C=C+1 +"RTN","VWREGIT",128,0) + ; +"RTN","VWREGIT",129,0) +INR() Q $O(RESULT(" "),-1)+1 +"RTN","VWREGIT",130,0) + ; +"RTN","VWREGIT",131,0) +CLNNUM(NUM) ;Clean NUM +"RTN","VWREGIT",132,0) + Q $TR(NUM," -^/~|\[]{}@!#$%&*()-_=+';:<>,.?") +"RTN","VWREGIT",133,0) + ; +"RTN","VWREGIT",134,0) +ALABEL(FL,FI) ; +"RTN","VWREGIT",135,0) + Q $S($D(^DIE(TNUM,"DIAB",FL,0,FI,0)):$TR($P(^(0),";",2),"""",""),1:$P(^DD(FI,$P(FSET,";",FL),0),"^")) +"RTN","VWREGIT",136,0) + ; +"RTN","VWREGIT",137,0) +SETMULTS ; +"RTN","VWREGIT",138,0) + K FSETM +"RTN","VWREGIT",139,0) + S FSET=$g(^DIE(TNUM,"DR",1,2)) +"RTN","VWREGIT",140,0) + Q:FSET="" +"RTN","VWREGIT",141,0) + ;S N=1 F S N=$O(^DIE(TNUM,"DR",N)) Q:'+N S N1=0 F S N1=$O(^DIE(TNUM,"DR",N,N1)) Q:'+N1 S FSETM(N1)=$E(^(N1),1,$L(^(N1))-1) +"RTN","VWREGIT",142,0) + S N=0 F S N=$O(^DIE(TNUM,"DR",2,N)) Q:'+N S X=^(N) S:$E(X,$L(X))=";" X=$E(X,1,$L(X)-1) S FSETM(N)=X +"RTN","VWREGIT",143,0) + ;S FSET=$E(FSET,1,$L(FSET)-1) +"RTN","VWREGIT",144,0) + F I=1:1:$L(FSET,";") S XF=$P(FSET,";",I) D +"RTN","VWREGIT",145,0) + . S FSETNUM(+XF)=$P(^DD(XFILE,+XF,0),"^")_"^"_$TR($P($G(^DIE(TNUM,"DIAB",I,0,XFILE,0)),";",2),"""","") +"RTN","VWREGIT",146,0) + . I +$P(^DD(2,+XF,0),"^",2) S $P(FSETNUM(+XF),"^",2)=+$P(^(0),"^",2) +"RTN","VWREGIT",147,0) + S N=0 F S N=$O(FSETNUM(N)) Q:'+N S FSETMAT($P(FSETNUM(N),"^"))="" +"RTN","VWREGIT",148,0) + S N=0 F S N=$O(FSETM(N)) Q:'+N S FSTRING=FSETM(N) D +"RTN","VWREGIT",149,0) + . F I=1:1:$L(FSTRING,";") S MF=$P(FSTRING,";",I),FSETMM(N,$P(^DD(N,MF,0),"^"))="" +"RTN","VWREGIT",150,0) + Q +"RTN","VWREGIT",151,0) + ; +"RTN","VWREGIT",152,0) +PID(DFN,TID,XID) ;Patient ID +"RTN","VWREGIT",153,0) + N C,XHRN +"RTN","VWREGIT",154,0) + K PAR +"RTN","VWREGIT",155,0) + D FIND^DIC(XFILE,"",".01;.02;.03;.09;.363;391","CM",$S($G(DFN):"`"_DFN,1:$G(XID)),"","B^AVWPID^SSN","","","ARR","LUERR") +"RTN","VWREGIT",156,0) + I '$O(ARR("DILIST",0)) S RESULT(1)="-1^NEW" Q +"RTN","VWREGIT",157,0) +PIDS I '$O(ARR("DILIST",2,1)) D Q +"RTN","VWREGIT",158,0) + . S:'DFN DFN=$G(ARR("DILIST",2,1)) D RECALL^DILFD(2,DFN_",",DUZ) +"RTN","VWREGIT",159,0) + . S NAME=$G(ARR("DILIST",1,1)) +"RTN","VWREGIT",160,0) + . S XSSN=$G(ARR("DILIST","ID",1,.09)) D:'$L(XSSN) +"RTN","VWREGIT",161,0) + .. S DA=DFN +"RTN","VWREGIT",162,0) + .. D PSEU^DGRPDD1 +"RTN","VWREGIT",163,0) + .. S (XSSN,$P(^DPT(DFN,0),"^",9))=L,^DPT("SSN",L,DFN)="" +"RTN","VWREGIT",164,0) + . ;S DOB=$G(ARR("DILIST","ID",1,.03)) +"RTN","VWREGIT",165,0) + . S DOB=$$GDOBT(DFN) +"RTN","VWREGIT",166,0) + . S SEX=$E($G(ARR("DILIST","ID",1,.02))) +"RTN","VWREGIT",167,0) + . S XID=$G(ARR("DILIST","ID",1,.363)) +"RTN","VWREGIT",168,0) + . I '$L($G(XHRN)),TID="HRN" S XHRN=$P($G(^AUPNPAT(DFN,41,1,0)),"^",2) +"RTN","VWREGIT",169,0) + . ;D GETS^DIQ(XFILE,DFN_",",FSET,"NIER","PAR","ERR") ;unused code +"RTN","VWREGIT",170,0) + . ;Note: "**" used to gain all fields in multiples in the file - shotgun technique .vs focused/jeb 2013 +"RTN","VWREGIT",171,0) + . D GETS^DIQ(XFILE,DFN_",","**","NIER","PAR","ERR") +"RTN","VWREGIT",172,0) + . D:$D(PAR(2,DFN_",","COUNTY","I")) +"RTN","VWREGIT",173,0) + .. S COUNTY=$G(PAR(2,DFN_",","COUNTY","I")),STATE=$G(PAR(2,DFN_",","STATE","I")) +"RTN","VWREGIT",174,0) + .. I STATE S PAR(2,DFN_",","COUNTY","E")=$P(^DIC(5,STATE,1,COUNTY,0),"^") +"RTN","VWREGIT",175,0) + . S RESULT($$INR)=DFN_"^"_XID_"^"_$P(NAME,",",2)_"^"_$P(NAME,",")_"^"_DOB_"^"_$E(SEX)_"^"_$G(^DPT(DFN,.1))_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"") +"RTN","VWREGIT",176,0) + . D FIELDS +"RTN","VWREGIT",177,0) + . S N=2 F S N=$O(RESULT(N)) Q:'+N S F=$P(RESULT(N),"^",2) I $D(FSETNUM(F)),$L($P(FSETNUM(F),"^",2)) S $P(RESULT(N),"^")=$P(FSETNUM(F),"^",2) +"RTN","VWREGIT",178,0) + . S N=2 F S N=$O(RESULT(N)) Q:'+N D +"RTN","VWREGIT",179,0) + .. S F=$P(RESULT(N),"^") +"RTN","VWREGIT",180,0) + .. S FDATA=$G(PAR(XFILE,DFN_",",F,"E")) +"RTN","VWREGIT",181,0) + .. S $P(RESULT(N),"^",3)=FDATA +"RTN","VWREGIT",182,0) + .. S $P(RESULT(N),"^",4)=$$HINT(XFILE,$P(RESULT(N),"^",2)) +"RTN","VWREGIT",183,0) + . S N=2 F S N=$O(RESULT(N)) Q:'+N D:+RESULT(N) +"RTN","VWREGIT",184,0) + .. S SN=+RESULT(N) Q:'$D(FSETM(SN)) +"RTN","VWREGIT",185,0) + .. S SNFLDS=FSETM(SN) +"RTN","VWREGIT",186,0) + .. S IX=.1 +"RTN","VWREGIT",187,0) + .. F I=1:1:$L(SNFLDS,";") S SNFN=$P(SNFLDS,";",I) S:SNFN RESULT(N+IX)=$P(^DD(SN,SNFN,0),"^")_"^"_SN_";"_SNFN_"^"_$$VPAR(SN)_"^^",IX=IX+.1 +"RTN","VWREGIT",188,0) + . S N=2 F S N=$O(RESULT(N)) Q:'+N K:+RESULT(N) RESULT(N) +"RTN","VWREGIT",189,0) + . S N=2 F S N=$O(RESULT(N)) Q:'+N D +"RTN","VWREGIT",190,0) + .. I $P(RESULT(N),"^",4)="" S $P(RESULT(N),"^",4)="" +"RTN","VWREGIT",191,0) + .. I $P(RESULT(N),"^",2)[";",$P($P(RESULT(N),"^",2),";")=2.101,+$P(RESULT(N),";",2)=.01,'$L($G(^DPT(DFN,.1))) S $P(RESULT(N),"^",3)=$$MV(DFN,$P($P(RESULT(N),"^",2),";"),$G(^DIE(TNUM,"DR",2,$P($P(RESULT(N),"^",2),";")) +"RTN","VWREGIT",192,0) + . S MATCH=1,$P(RESULT(0),"^",2)=1 +"RTN","VWREGIT",193,0) + ;Below - list of possibles found +"RTN","VWREGIT",194,0) +PIDM S (C,N)=0 F S N=$O(ARR("DILIST",1,N)) Q:'+N D +"RTN","VWREGIT",195,0) + . S DFN=ARR("DILIST",2,N),C=C+1 +"RTN","VWREGIT",196,0) + . S XID=$P($G(^DPT(DFN,.36)),"^",3) +"RTN","VWREGIT",197,0) + . S XSSN=ARR("DILIST","ID",N,.09) +"RTN","VWREGIT",198,0) + . S XHRN=$P($G(^AUPNPAT(DFN,41,1,0)),"^",2) +"RTN","VWREGIT",199,0) + . S XNAME=ARR("DILIST",1,N) +"RTN","VWREGIT",200,0) + . S XDOB=ARR("DILIST","ID",N,.03) +"RTN","VWREGIT",201,0) + . S XID=$S($L(XID):XID,$L(XSSN):XSSN,1:"") +"RTN","VWREGIT",202,0) + . S RESULT($$INR)=$S($L(XID):XID,1:$L(XHRN),1:"")_"~"_XNAME_"~"_XDOB_"~"_$P(^DPT(DFN,0),"^",2)_"~"_DFN +"RTN","VWREGIT",203,0) + . S $P(RESULT(0),"^",2)=C +"RTN","VWREGIT",204,0) + Q +"RTN","VWREGIT",205,0) + ; +"RTN","VWREGIT",206,0) +EN(RESULT) ;Template name and ID labels +"RTN","VWREGIT",207,0) + ;Parse stuff into Fileman-ese +"RTN","VWREGIT",208,0) + ;Testing - D EN^VWREGIT(.RESULT,"REG(1767)^^LEMON^^") +"RTN","VWREGIT",209,0) + ;;M ^TMP("IDSTR",1)=IDSTR +"RTN","VWREGIT",210,0) + ;;S RESULT(0)="[ID]" +"RTN","VWREGIT",211,0) + ;;S RESULT(1)="-1^NEW" +"RTN","VWREGIT",212,0) + ;;Q +"RTN","VWREGIT",213,0) + ;end testing +"RTN","VWREGIT",214,0) + ; +"RTN","VWREGIT",215,0) + ;Get the input template list +"RTN","VWREGIT",216,0) + ;housekeeping +"RTN","VWREGIT",217,0) + S DTIME=99999 +"RTN","VWREGIT",218,0) + ;end housekeeping +"RTN","VWREGIT",219,0) + ; +"RTN","VWREGIT",220,0) + K AR,RESULT +"RTN","VWREGIT",221,0) + N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO +"RTN","VWREGIT",222,0) + S RESULT(0)=$$CONTROL^VWREGIT2() +"RTN","VWREGIT",223,0) + S RESULT(1)="-1^No templates found" +"RTN","VWREGIT",224,0) + S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY") +"RTN","VWREGIT",225,0) + S FILE="regit.txt" +"RTN","VWREGIT",226,0) + S P4=1 +"RTN","VWREGIT",227,0) + S P5="" +"RTN","VWREGIT",228,0) + S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5) +"RTN","VWREGIT",229,0) + I 'X K T,TITLE D Q ;Error report - home dir not found +"RTN","VWREGIT",230,0) + . S TITLE=$P(RESULT(1),"^") +"RTN","VWREGIT",231,0) + . S T(1)="The home directory could not be located." +"RTN","VWREGIT",232,0) + . S T(2)="End of data error message" +"RTN","VWREGIT",233,0) + . D ME(X) +"RTN","VWREGIT",234,0) + . K T,X +"RTN","VWREGIT",235,0) + S:+RESULT(0) $P(RESULT(0),"^",2)=HD +"RTN","VWREGIT",236,0) + I $O(AR(0)) S RESULT(1)="[TEMPLATES]" +"RTN","VWREGIT",237,0) + S N=0 F S N=$O(AR(N)) Q:'+N D +"RTN","VWREGIT",238,0) + . Q:$E(AR(N))="*" +"RTN","VWREGIT",239,0) + . Q:'+$P(AR(N),"(",2) +"RTN","VWREGIT",240,0) + . Q:$P(^DIE(+$P(AR(N),"(",2),0),"^",4)'=2 ;must be pat file +"RTN","VWREGIT",241,0) + . S RESULT($$INR)=AR(N) +"RTN","VWREGIT",242,0) + S RESULT($$INR)="[ID]" +"RTN","VWREGIT",243,0) + S N=0 F S N=$O(RESULT(N)) Q:'+N K:RESULT(N)="" RESULT(N) +"RTN","VWREGIT",244,0) + I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found" +"RTN","VWREGIT",245,0) + K AR +"RTN","VWREGIT",246,0) + Q +"RTN","VWREGIT",247,0) + ; +"RTN","VWREGIT",248,0) +PAT(RESULT,IDSTR) ; +"RTN","VWREGIT",249,0) + ; ********************************************************** +"RTN","VWREGIT",250,0) + ; *IDSTR____Template(IEN)^ID/HRN/SSN:ID#^NAME^DOB^GENDER * +"RTN","VWREGIT",251,0) + ; * ^NEW<-EMPTY IF NOT NEW PT * +"RTN","VWREGIT",252,0) + ; *Action___Execute patient look up first with HRN/ID, * +"RTN","VWREGIT",253,0) + ; * then NAME; DOB is confirming ID if found * +"RTN","VWREGIT",254,0) + ; * If not found RESULT(0)="-1^NEW" * +"RTN","VWREGIT",255,0) + ; ********************************************************** +"RTN","VWREGIT",256,0) + ; +"RTN","VWREGIT",257,0) + N DFN,FN,FSET,J,LABEL,MATCH,N,PID,TNUM,XAID,XDOB,XF,XFILE,XFLD,XHRN,XLABEL,XNAME,XUNM,XUMOV,XUFAM,XUOUT,XUREST,XUSP +"RTN","VWREGIT",258,0) + N NAME,XDOB,SEX,FAIL,STR,TID,FAIL,TID,IEN +"RTN","VWREGIT",259,0) + K RESULT,PAR,ARR,SPAR,LUERR,ERR +"RTN","VWREGIT",260,0) + S RESULT(0)="[ID]^0" +"RTN","VWREGIT",261,0) + S TNUM=+$P(IDSTR,"(",2) +"RTN","VWREGIT",262,0) + Q:'TNUM ;No template name from client +"RTN","VWREGIT",263,0) + I '$D(^DIE(TNUM)) S RESULT(0)="-1^Template not found" G XOUT +"RTN","VWREGIT",264,0) + S XFILE=$P(^DIE(TNUM,0),"^",4) +"RTN","VWREGIT",265,0) + S MATCH=0 +"RTN","VWREGIT",266,0) + S DFN=0 +"RTN","VWREGIT",267,0) + ;D SETMULTS +"RTN","VWREGIT",268,0) + S XEC=$$CFDFN^VWREGIT2(IDSTR) +"RTN","VWREGIT",269,0) + I $L(XEC) D:XEC'="XOUT" @XEC G XOUT ;Found DFN(s)... +"RTN","VWREGIT",270,0) + S DFN=+$P($P(IDSTR,"^",3),"(",2) +"RTN","VWREGIT",271,0) + I 'DFN,$P(IDSTR,"^",6) D D NEWPAT,FIELDS Q +"RTN","VWREGIT",272,0) + . S TID=$P($P(IDSTR,"^",2),":"),ID=$P($P(IDSTR,"^",2),":",2) +"RTN","VWREGIT",273,0) + . K:TID="SSN" VWREG ;Allow triggers and xfrs for the USA | jeb 2013 +"RTN","VWREGIT",274,0) + . S ID=$S($L(ID):$$CLNNUM(ID),1:"") +"RTN","VWREGIT",275,0) + . S NAME=$$UP^XLFSTR($P(IDSTR,"^",3)) +"RTN","VWREGIT",276,0) + . S XDOB=$P(IDSTR,"^",4) +"RTN","VWREGIT",277,0) + . S GENDER=$$UP^XLFSTR($P(IDSTR,"^",5)) +"RTN","VWREGIT",278,0) + . ;1901,.301,391 From Sam Habiel's UJOPTREG c 2010,2011 by permission +"RTN","VWREGIT",279,0) + . S DATA(XFILE,"+1,",1901)="NO" ; Veteran? +"RTN","VWREGIT",280,0) + . S DATA(XFILE,"+1,",.301)="NO" ; Service Connected +"RTN","VWREGIT",281,0) + . S DATA(XFILE,"+1,",391)="NON-VETERAN (OTHER)" ; Type of Patient +"RTN","VWREGIT",282,0) + . S DATA(XFILE,"+1,",.01)=NAME +"RTN","VWREGIT",283,0) + . S DATA(XFILE,"+1,",.02)=GENDER +"RTN","VWREGIT",284,0) + . S DATA(XFILE,"+1,",.03)=XDOB +"RTN","VWREGIT",285,0) + . S DATA(XFILE,"+1,",.09)=$S(TID="SSN":ID,1:"") +"RTN","VWREGIT",286,0) + . S DATA(XFILE,"+1,",.363)=ID +"RTN","VWREGIT",287,0) + . D UPDATE^DIE("E","DATA","IEN","VWERR") +"RTN","VWREGIT",288,0) + . Q:$D(VWERR) +"RTN","VWREGIT",289,0) + . S DFN=IEN(1) D RECALL^DILFD(2,DFN_",",DUZ) +"RTN","VWREGIT",290,0) + . ;Set up IHS Patient file (9000001) +"RTN","VWREGIT",291,0) + . D NOW^%DTC +"RTN","VWREGIT",292,0) + . S AUPN=IEN(1),$P(AUPN,"^",2)=X,$P(AUPN,"^",11)=DUZ,$P(AUPN,"^",12)=X +"RTN","VWREGIT",293,0) + . S ^AUPNPAT(+IEN(1))=AUPN,^AUPNPAT("B",+IEN(1),+IEN(1))="" +"RTN","VWREGIT",294,0) + . I TID="HRN",'$O(^AUPNPAT("D",+IEN(1),ID,0)) D +"RTN","VWREGIT",295,0) + .. S ^AUPNPAT(+IEN(1),41,1,0)="1^"_ID +"RTN","VWREGIT",296,0) + .. S $P(^AUPNPAT(+IEN(1),41,0),"^",3)=ID,$P(^(0),"^",4)=$P(^(0),"^",4)+1 +"RTN","VWREGIT",297,0) +LAUP . L ^AUPNPAT(0):1 G LAUP:'$T D L +"RTN","VWREGIT",298,0) + .. S $P(^AUPNPAT(0),"^",3)=+IEN(1) +"RTN","VWREGIT",299,0) + .. S $P(^AUPNPAT(0),"^",4)=$P(^(0),"^",4)+1 +"RTN","VWREGIT",300,0) + D PID(DFN,$P($P(IDSTR,"^",2),":"),$P($P(IDSTR,"^",2),":",2)) +"RTN","VWREGIT",301,0) + ;D:'MATCH&($P(RESULT(0),"^",2)<2) FIELDS +"RTN","VWREGIT",302,0) +XOUT K PAR,ARR,ERR,SPAR,LUERR Q +"RTN","VWREGIT",303,0) + ; +"RTN","VWREGIT",304,0) +NEWPAT ;Set up new patient data return +"RTN","VWREGIT",305,0) + S $P(RESULT(0),"^",2)=1 +"RTN","VWREGIT",306,0) + ;S DFN=$G(IEN(1)) +"RTN","VWREGIT",307,0) + I TID'="SSN" D +"RTN","VWREGIT",308,0) + . S DA=DFN +"RTN","VWREGIT",309,0) + . D PSEU^DGRPDD1 +"RTN","VWREGIT",310,0) + . S (XSSN,$P(^DPT(DFN,0),"^",9))=L,^DPT("SSN",L,DFN)="" +"RTN","VWREGIT",311,0) + S RESULT($$INR)=DFN_"^"_ID_"^"_NAME_"^"_XDOB_"^"_GENDER_"^"_$G(^DPT(DFN,.1))_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"N/A") +"RTN","VWREGIT",312,0) + Q +"RTN","VWREGIT",313,0) + ; +"RTN","VWREGIT2") +0^9^B100003944 +"RTN","VWREGIT2",1,0) +VWREGIT2 ;VWEHR/Jim Bell, et al... - World VistA Input Template Utility +"RTN","VWREGIT2",2,0) + ;;1.0;WORLD VISTA;** **;;Build 1 +"RTN","VWREGIT2",3,0) + ; +"RTN","VWREGIT2",4,0) + ;Continued from VWREGIT +"RTN","VWREGIT2",5,0) + ; +"RTN","VWREGIT2",6,0) + ;GNU License: See WVLIC.txt +"RTN","VWREGIT2",7,0) + ;Modified FOIA VISTA, +"RTN","VWREGIT2",8,0) + ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU +"RTN","VWREGIT2",9,0) + Q +"RTN","VWREGIT2",10,0) + ; +"RTN","VWREGIT2",11,0) +PI ;Post Installation install +"RTN","VWREGIT2",12,0) + ;; NOTE: The parameter definition is installed but there is no installation for +"RTN","VWREGIT2",13,0) + ;;the actual parameter and value. Do it here. +"RTN","VWREGIT2",14,0) + ;parameter value attempt +"RTN","VWREGIT2",15,0) + ;Set a home directory for editing; SYSTEM (DIC(4,) and DOMAIN (DIC(4.2,) only:"/home/vista/regparam/" +"RTN","VWREGIT2",16,0) + S PARD=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0)) +"RTN","VWREGIT2",17,0) + I PARD D +"RTN","VWREGIT2",18,0) + . L +^XTV(8989.5,0):1 D L -^XTV(8989.5,0) +"RTN","VWREGIT2",19,0) + .. S NEW=$O(^XTV(8989.5," "),-1)+1 +"RTN","VWREGIT2",20,0) + .. S $P(^XTV(8989.5,0),"^",3)=NEW +"RTN","VWREGIT2",21,0) + .. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1 +"RTN","VWREGIT2",22,0) + .. S $P(^XTV(8989.5,NEW,0),"^")="1;DIC(4," +"RTN","VWREGIT2",23,0) + .. S $P(^XTV(8989.5,NEW,0),"^",2)=PARD +"RTN","VWREGIT2",24,0) + .. S $P(^XTV(8989.5,NEW,0),"^",3)=1 +"RTN","VWREGIT2",25,0) + .. S ^XTV(8989.5,NEW,1)="/home/vista/regparam/" +"RTN","VWREGIT2",26,0) + .. S DA=NEW,DIK="^XTV(8989.5," D IX^DIK +"RTN","VWREGIT2",27,0) + .. S NEW2=$O(^XTV(8989.5," "),-1)+1 +"RTN","VWREGIT2",28,0) + .. S $P(^XTV(8989.5,0),"^",3)=NEW2 +"RTN","VWREGIT2",29,0) + .. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1 +"RTN","VWREGIT2",30,0) + .. S $P(^XTV(8989.5,NEW2,0),"^")="9;DIC(4.2," +"RTN","VWREGIT2",31,0) + .. S $P(^XTV(8989.5,NEW2,0),"^",2)=PARD +"RTN","VWREGIT2",32,0) + .. S $P(^XTV(8989.5,NEW2,0),"^",3)=1 +"RTN","VWREGIT2",33,0) + .. S ^XTV(8989.5,NEW2,1)="/home/vista/regparam/" +"RTN","VWREGIT2",34,0) + .. S DA=NEW2,DIK="^XTV(8989.5," D IX^DIK +"RTN","VWREGIT2",35,0) + .. ;S ^XTV(8989.5,"AC",PARD,"1;DIC(4,",1)="/home/vista/regparam/" +"RTN","VWREGIT2",36,0) + .. ;S ^XTV(8989.5,"AC",PARD,"1;DIC(4,",1,NE)="" +"RTN","VWREGIT2",37,0) + .. ;S ^XTV(8989.5,"B","1;DIC(4,",NE)="" +"RTN","VWREGIT2",38,0) + ; +"RTN","VWREGIT2",39,0) + ;Mailgroup VW REG ERROR REPORT - add programmer's email +"RTN","VWREGIT2",40,0) + S DA(1)=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0)) +"RTN","VWREGIT2",41,0) + Q:'DA(1) +"RTN","VWREGIT2",42,0) + S DIC="^XMB(3.8,"_DA(1)_",6," +"RTN","VWREGIT2",43,0) + S X="jbellco65@gmail.com" +"RTN","VWREGIT2",44,0) + S DIC(0)="LZ" +"RTN","VWREGIT2",45,0) + D FILE^DICN +"RTN","VWREGIT2",46,0) + Q +"RTN","VWREGIT2",47,0) + ; +"RTN","VWREGIT2",48,0) +ABSDFN(RESULT,IDSTR) ;Absolute DFN +"RTN","VWREGIT2",49,0) + N TNUM,DFN,XFILE +"RTN","VWREGIT2",50,0) + K ERR,RESULT,PAR,FSET,FSETMAT +"RTN","VWREGIT2",51,0) + S RESULT(0)="ID^-1" +"RTN","VWREGIT2",52,0) + S TNUM=+$P($P(IDSTR,"^"),"(",2) I 'TNUM S RESULT(1)="Template not supplied. Please retry..." Q +"RTN","VWREGIT2",53,0) + S DFN=$P(IDSTR,"^",2) I 'DFN S RESULT(1)="Patient not supplied. Please try again..." Q +"RTN","VWREGIT2",54,0) + S XFILE=$P(^DIE(TNUM,0),"^",4) +"RTN","VWREGIT2",55,0) + ;D SETMULTS^VWREGIT +"RTN","VWREGIT2",56,0) + D RECALL^DILFD(2,DFN_",",DUZ) +"RTN","VWREGIT2",57,0) + D GETS^DIQ(XFILE,DFN_",","**","NIER","PAR","ERR") +"RTN","VWREGIT2",58,0) + S $P(RESULT(0),"^",2)=1 +"RTN","VWREGIT2",59,0) + S $P(RESULT(1),"^",1)=DFN +"RTN","VWREGIT2",60,0) + S $P(RESULT(1),"^",2)=$G(ARR("DILIST","ID",1,.363)) +"RTN","VWREGIT2",61,0) + S $P(RESULT(1),"^",3)=$G(ARR("DILIST","ID",1,.01)) +"RTN","VWREGIT2",62,0) + ;S $P(RESULT(1),"^",4)=$G(ARR("DILIST","ID",1,.03)) +"RTN","VWREGIT2",63,0) + S $P(RESULT(1),"^",4)=$$GDOBT^VWREGIT(DFN) +"RTN","VWREGIT2",64,0) + S $P(RESULT(1),"^",5)=$E($G(ARR("DILIST","ID",1,.02))) +"RTN","VWREGIT2",65,0) + S $P(RESULT(1),"^",6)=$S($G(^DPT(DFN,.1)):^(.1),1:"N/A")_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"") +"RTN","VWREGIT2",66,0) + S $P(RESULT(1),"^",7)=$G(ARR("DILIST",1,.09)) +"RTN","VWREGIT2",67,0) + D FIELDS^VWREGIT +"RTN","VWREGIT2",68,0) + S N=2 F S N=$O(RESULT(N)) Q:'+N S F=$P(RESULT(N),"^",2) I $D(FSETNUM(F)),$L($P(FSETNUM(F),"^",2)) S $P(RESULT(N),"^")=$P(FSETNUM(F),"^",2) +"RTN","VWREGIT2",69,0) + S N=2 F S N=$O(RESULT(N)) Q:'+N D +"RTN","VWREGIT2",70,0) + . S F=$P(RESULT(N),"^") +"RTN","VWREGIT2",71,0) + . S FDATA=$G(PAR(XFILE,DFN_",",F,"E")) +"RTN","VWREGIT2",72,0) + . S $P(RESULT(N),"^",3)=FDATA +"RTN","VWREGIT2",73,0) + . S $P(RESULT(N),"^",4)=$$HINT^VWREGIT(XFILE,$P(RESULT(N),"^",2)) +"RTN","VWREGIT2",74,0) + S N=2 F S N=$O(RESULT(N)) Q:'+N D:+RESULT(N) +"RTN","VWREGIT2",75,0) + . S SN=+RESULT(N) Q:'$D(FSETM(SN)) +"RTN","VWREGIT2",76,0) + . S SNFLDS=FSETM(SN) +"RTN","VWREGIT2",77,0) + . S IX=.1 +"RTN","VWREGIT2",78,0) + . F I=1:1:$L(SNFLDS,";") S SNFN=$P(SNFLDS,";",I) S:SNFN RESULT(N+IX)=$P(^DD(SN,SNFN,0),"^")_"^"_SN_";"_SNFN_"^"_$$VPAR^VWREGIT(SN)_"^^",IX=IX+.1 +"RTN","VWREGIT2",79,0) + S N=2 F S N=$O(RESULT(N)) Q:'+N K:+RESULT(N) RESULT(N) +"RTN","VWREGIT2",80,0) + S N=2 F S N=$O(RESULT(N)) Q:'+N D +"RTN","VWREGIT2",81,0) + . I $P(RESULT(N),"^",4)="" S $P(RESULT(N),"^",4)="" +"RTN","VWREGIT2",82,0) + . I $P(RESULT(N),"^",2)[";",$P($P(RESULT(N),"^",2),";")=2.101,+$P(RESULT(N),";",2)=.01,'$L($G(^DPT(DFN,.1))) S $P(RESULT(N),"^",3)="NOW" +"RTN","VWREGIT2",83,0) + Q +"RTN","VWREGIT2",84,0) + ; +"RTN","VWREGIT2",85,0) +CFDFN(STRING) ;Check for a DFN +"RTN","VWREGIT2",86,0) + ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +"RTN","VWREGIT2",87,0) + ; | STRING___TEMPLATE(IEN)^ID^NAME^DOB^GENDER | +"RTN","VWREGIT2",88,0) + ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +"RTN","VWREGIT2",89,0) + ; +"RTN","VWREGIT2",90,0) + N NAME,ID +"RTN","VWREGIT2",91,0) + S ID=$$CLNNUM^VWREGIT($P($P(STRING,"^",2),":",2)) +"RTN","VWREGIT2",92,0) + S TID=$P($P(STRING,"^",2),":") +"RTN","VWREGIT2",93,0) + I TID="HRN" S DFN=$O(^AUPNPAT("D",ID,0)) S $P(IDSTR,"^",2)=DFN D ABSDFN(.RESULT,IDSTR) Q "XOUT" +"RTN","VWREGIT2",94,0) + S NAME=$$UP^XLFSTR($P(STRING,"^",3)) +"RTN","VWREGIT2",95,0) + D FIND^DIC(2,"",".01;.02;.03;.09;.363","CM",$S(+ID:ID,1:NAME),"","B^SSN^AVWPID","","","ARR","LUERR") +"RTN","VWREGIT2",96,0) + I '$O(ARR("DILIST",0)) Q "" +"RTN","VWREGIT2",97,0) + ;I '$O(ARR("DILIST",1,1)),$L(NAME),ARR("DILIST",1,1)'=NAME Q "MM" +"RTN","VWREGIT2",98,0) + I $O(ARR("DILIST",1,1)) Q "PIDM" ;multiple found +"RTN","VWREGIT2",99,0) + I '$O(ARR("DILIST",1,1)) D D ABSDFN(.RESULT,IDSTR) Q "XOUT" ;Single found +"RTN","VWREGIT2",100,0) + . S $P(IDSTR,"^",2)=ARR("DILIST",2,1) +"RTN","VWREGIT2",101,0) + Q "" +"RTN","VWREGIT2",102,0) + ; +"RTN","VWREGIT2",103,0) +ST(TN) ;Screen these templates for PATIENT FILE(#2):1,1:0 +"RTN","VWREGIT2",104,0) + I $E($P(^DIE(TN,0),"^"))="*" Q 0 +"RTN","VWREGIT2",105,0) + I $P(^DIE(TN,0),"^",4)'=2 Q 0 +"RTN","VWREGIT2",106,0) + Q 1 +"RTN","VWREGIT2",107,0) + ; +"RTN","VWREGIT2",108,0) +INR() Q $O(RESULT(" "),-1)+1 +"RTN","VWREGIT2",109,0) + ; +"RTN","VWREGIT2",110,0) +CLNNUM(NUM) ;Clean NUM +"RTN","VWREGIT2",111,0) + Q $TR(NUM," -^/~|\[]{}@!#$%&*()-_=+';:<>,.?") +"RTN","VWREGIT2",112,0) + ; +"RTN","VWREGIT2",113,0) +CONTROL() ;Check for CONTROL status +"RTN","VWREGIT2",114,0) + N X S X=$O(^DIC(19,"B","VW REG IT CONTROL",0)) +"RTN","VWREGIT2",115,0) + I 'X Q 0 ;Ain't no option there +"RTN","VWREGIT2",116,0) + Q $S($D(^VA(200,DUZ,203,"B",X)):1,1:0) +"RTN","VWREGIT2",117,0) + ; +"RTN","VWREGIT2",118,0) +GETHD(RESULT) ;Get home directory for set up +"RTN","VWREGIT2",119,0) + S RESULT(0)=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY") +"RTN","VWREGIT2",120,0) + Q +"RTN","VWREGIT2",121,0) + ; +"RTN","VWREGIT2",122,0) +SAVEHD(RESULT,NHD) ;Saves Home Directory changes to PARAMETER file +"RTN","VWREGIT2",123,0) + ; Called from Remote Procedure VW REG SAVE HD +"RTN","VWREGIT2",124,0) + ; NHD_____New Home Directory +"RTN","VWREGIT2",125,0) + ; +"RTN","VWREGIT2",126,0) + I NHD="" S RESULT(0)="-1^No data from client" Q +"RTN","VWREGIT2",127,0) + K RESULT,SCRATCH +"RTN","VWREGIT2",128,0) + N HDIEN,N +"RTN","VWREGIT2",129,0) + S HDIEN=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0)) +"RTN","VWREGIT2",130,0) + I 'HDIEN D Q +"RTN","VWREGIT2",131,0) + . S T(1)="Error reported from routine SAVEHD^VWREGIT:" +"RTN","VWREGIT2",132,0) + . S T(2)="The PARAMETER DEFINITION ""VW GUI REG TEMPLATE DIRECTORY"" was" +"RTN","VWREGIT2",133,0) + . S T(3)="not found." +"RTN","VWREGIT2",134,0) + . D ME^VWREGIT("NO PARAMETER DEFINITION") +"RTN","VWREGIT2",135,0) + . S RESULT(0)="-1^Error sent to VW REG mail group" +"RTN","VWREGIT2",136,0) + S X="^XTV(8989.5,""AC"","_HDIEN_")" F S X=$Q(@X) Q:+$P(X,",",3)'=HDIEN S:$L(X,",")>6 SCRATCH(+$P(X,",",7))="" +"RTN","VWREGIT2",137,0) + S N=0 F S N=$O(SCRATCH(N)) Q:'+N D S RESULT(0)=1 +"RTN","VWREGIT2",138,0) + . S ^XTV(8989.5,N,1)=NHD +"RTN","VWREGIT2",139,0) + . S DA=N,DIK="^XTV(8989.5," D IX^DIK +"RTN","VWREGIT2",140,0) + . K DIC,DA,DIK +"RTN","VWREGIT2",141,0) + Q +"RTN","VWREGIT2",142,0) + ; +"RTN","VWREGIT2",143,0) +SAVE(RESULT,FLDS) ;Template fields being returned with values +"RTN","VWREGIT2",144,0) + ;UPCASE everything! +"RTN","VWREGIT2",145,0) + ;;Testing +"RTN","VWREGIT2",146,0) + ;;S RESULT(0)="-1 Q +"RTN","VWREGIT2",147,0) + ;;End Testing +"RTN","VWREGIT2",148,0) + K AR,ERR,MFLD,DIERR +"RTN","VWREGIT2",149,0) + N N,TNUM,XFILE,C,PLID,COUNTY,PSSN,DA,DIE,DIC,DR,STR,VAFCA08 +"RTN","VWREGIT2",150,0) + ;W " ;Used for "instantiating" a hard error +"RTN","VWREGIT2",151,0) + S C=0,RESULT(0)="" +"RTN","VWREGIT2",152,0) + S X="FLDS" F S X=$Q(@X) Q:X="" S STR=@X,@X=$$UP^XLFSTR(STR) +"RTN","VWREGIT2",153,0) + S VWREG=$S($P(FLDS(0),"^",2)="VWRGUI":1,1:0) +"RTN","VWREGIT2",154,0) + S VAFCA08=1 ;Prevents execution xfrs 991 and 992 of field 1901 and related other fields +"RTN","VWREGIT2",155,0) + S TNUM=+$P(FLDS(0),"(",2) +"RTN","VWREGIT2",156,0) + S XFILE=$P(^DIE(TNUM,0),"^",4) +"RTN","VWREGIT2",157,0) + S $P(FLDS(4),"^",2)=$$CLNNUM($P(FLDS(4),"^",2)) +"RTN","VWREGIT2",158,0) + ;VA abnormal anomalies not experienced in the outside world +"RTN","VWREGIT2",159,0) + S N=0 F S N=$O(FLDS(N)) Q:'+N D +"RTN","VWREGIT2",160,0) + . S LFILE=$S($P(FLDS(N),"^")[";":+FLDS(N),1:XFILE) +"RTN","VWREGIT2",161,0) + . S LFLD=$P(FLDS(N),"^") +"RTN","VWREGIT2",162,0) + . S LFLD=$S(LFLD[";":$P($P(LFLD,"^"),";",2),1:LFLD) +"RTN","VWREGIT2",163,0) + . I $P(^DD(LFILE,+LFLD,0),"^")="PRIMARY LONG ID" S PLID=1 +"RTN","VWREGIT2",164,0) + . I $P(^DD(LFILE,+LFLD,0),"^")["COUNTY" S COUNTY=FLDS(N) K FLDS(N) +"RTN","VWREGIT2",165,0) + ;End VA abnormal anomalies +"RTN","VWREGIT2",166,0) + S DFN=+$P(FLDS(1),"(",2) +"RTN","VWREGIT2",167,0) +DFN ; +"RTN","VWREGIT2",168,0) + ;Check standard ID fields (ID = NOT in the VA meaning): .01,.02,.03,.36^3 for outside the U.S. or 0^9 in the U.S. +"RTN","VWREGIT2",169,0) + I $P(^DPT(DFN,0),"^")'=$P($P(FLDS(1),"^",2),"(") S AR(XFILE,DFN_",",$P(FLDS(1),"^"))=$P($P(FLDS(1),"^",2),"(") +"RTN","VWREGIT2",170,0) + I $P(^DPT(DFN,0),"^",2)'=$P(FLDS(2),"^") S AR(XFILE,DFN_",",$P(FLDS(2),"^"))=$S($P(FLDS(2),"^",2)="F":"FEMALE",1:"MALE") +"RTN","VWREGIT2",171,0) + S X=$P(FLDS(3),"^",2) D ^%DT I $P(^DPT(DFN,0),"^",3)'=Y S AR(XFILE,DFN_",",$P(FLDS(3),"^"))=$P(FLDS(3),"^",2) +"RTN","VWREGIT2",172,0) + ;S FLD=$P(FLDS(4),"^"),PIECE=$S(FLD=.363:3,1:9),SUBS=$S(FLD=.363:.36,1:0) +"RTN","VWREGIT2",173,0) + ;I $P(^DPT(DFN,SUBS),"^",PIECE)'=$P(FLDS(4),"^",2) S AR(XFILE,DFN_",",FLD)=$P(FLDS(4),"^",2) +"RTN","VWREGIT2",174,0) + S N=4 F S N=$O(FLDS(N)) Q:'+N S:FLDS(N)'[";" AR(XFILE,DFN_",",$P(FLDS(N),"^"))=$P(FLDS(N),"^",2) D:FLDS(N)[";" +"RTN","VWREGIT2",175,0) + . I '$D(MFLD($P(FLDS(N),";"))) S MFLD=$P(FLDS(N),";"),MFLD(MFLD)=FLDS(N) +"RTN","VWREGIT2",176,0) + . E S MFLD($P(FLDS(N),";"))=MFLD($P(FLDS(N),";"))_"~"_$P(FLDS(N),";",2) +"RTN","VWREGIT2",177,0) + I $D(MFLD) S C=1,N=0 F S N=$O(MFLD(N)) Q:'+N S C=C+1,CN=0 F I=1:1:$L(MFLD(N),"~") S CN=CN+1,X=$P($P(MFLD(N),";",2),"~",I),AR(N,"+"_C_","_DFN_",",$P(X,"^"))=$P(X,"^",2) +"RTN","VWREGIT2",178,0) + D UPDATE^DIE("E","AR","","ERR") ;Edit existing entries noted by $D(DFN) +"RTN","VWREGIT2",179,0) + N Y,X,% D NOW^%DTC S Y=% X ^DD("DD") +"RTN","VWREGIT2",180,0) + S RESULT(0)=1_"^"_Y +"RTN","VWREGIT2",181,0) +SOUT Q +"RTN","VWREGIT2",182,0) + ; +"RTN","VWREGIT2",183,0) +UTF(RESULT,UTFLIST) ;Update Linux Template file (regit.txt) +"RTN","VWREGIT2",184,0) + I $O(UTFLIST(" "),-1)=0 S RESULT(0)="-1" Q +"RTN","VWREGIT2",185,0) + K RESULT +"RTN","VWREGIT2",186,0) + N HD,DOTHIS,N,NF +"RTN","VWREGIT2",187,0) + S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY") +"RTN","VWREGIT2",188,0) + I +$P($G(^%ZOSF("OS")),"^",2)=19 D +"RTN","VWREGIT2",189,0) + . S DOTHIS="rm -f "_HD_"regit2.txt" ZSYSTEM DOTHIS ;Remove the prior copy +"RTN","VWREGIT2",190,0) + . S DOTHIS="cp "_HD_"regit.txt"_" "_HD_"regit2.txt" ZSYSTEM DOTHIS ;Copy the main regit file for safekeeping +"RTN","VWREGIT2",191,0) + . S DOTHIS="rm -f "_HD_"regit.txt" ZSYSTEM DOTHIS ;Kill the main regit template file +"RTN","VWREGIT2",192,0) + S RESULT(1)="[TEMPLATES]",N=0 F S N=$O(UTFLIST(N)) Q:'+N S RESULT($$INR)=UTFLIST(N) +"RTN","VWREGIT2",193,0) + S RESULT($$INR)="[ID]" +"RTN","VWREGIT2",194,0) + S X=$$GTF^%ZISH($NA(RESULT(1)),1,HD,"regit.txt") +"RTN","VWREGIT2",195,0) + Q +"RTN","VWREGIT2",196,0) + ; +"RTN","VWREGIT2",197,0) +GT(RESULT,XHOW) ;Get Templates from INPUT TEMPLATE FILE (.402) +"RTN","VWREGIT2",198,0) + ; ********************************************* +"RTN","VWREGIT2",199,0) + ; * XHOW____ALL, DUZ, NAMESPACE, USER/NUM * +"RTN","VWREGIT2",200,0) + ; * RETURN ARRAY__List of template names(IEN) * +"RTN","VWREGIT2",201,0) + ; ********************************************* +"RTN","VWREGIT2",202,0) + K RESULT,AR +"RTN","VWREGIT2",203,0) + N IEN,NAME,N,USER +"RTN","VWREGIT2",204,0) + S XHOW=$$UP^XLFSTR(XHOW) ;UPCASE EVERYTHING! +"RTN","VWREGIT2",205,0) + I XHOW="" D Q +"RTN","VWREGIT2",206,0) + . S RESULT(0)="I could not complete your request." +"RTN","VWREGIT2",207,0) + . S RESULT(1)="Ensure that one of the check boxes is checked." +"RTN","VWREGIT2",208,0) + . S RESULT(2)="Thank you, the Management." +"RTN","VWREGIT2",209,0) + I XHOW="ALL" D Q +"RTN","VWREGIT2",210,0) + . S RESULT(0)="Number of Templates: " +"RTN","VWREGIT2",211,0) + . S (C,N)=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N S X=$P(^(N,0),"^") S:$$ST(N) AR(X,I)=X_"("_N_")" +"RTN","VWREGIT2",212,0) + . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X,C=C+1 +"RTN","VWREGIT2",213,0) + . K AR +"RTN","VWREGIT2",214,0) + . S $P(RESULT(0),": ",2)=C K C +"RTN","VWREGIT2",215,0) + I XHOW="DUZ" D Q +"RTN","VWREGIT2",216,0) + . S RESULT(0)="Number of templates: " +"RTN","VWREGIT2",217,0) + . S (C,IEN)=0 F S IEN=$O(^DIE(IEN)) Q:'+IEN I $P(^(IEN,0),"^",5)=DUZ,$$ST(IEN) D +"RTN","VWREGIT2",218,0) + .. S C=C+1 +"RTN","VWREGIT2",219,0) + .. S NAME=$P(^(0),"^")_"("_IEN_")" +"RTN","VWREGIT2",220,0) + .. S RESULT($$INR)=NAME +"RTN","VWREGIT2",221,0) + . S $P(RESULT(0),":",2)=C +"RTN","VWREGIT2",222,0) + I +XHOW D Q +"RTN","VWREGIT2",223,0) + . S RESULT(0)="Number of templates: " +"RTN","VWREGIT2",224,0) + . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N S X=^(N,0) D +"RTN","VWREGIT2",225,0) + .. Q:$P(X,"^",5)'=XHOW +"RTN","VWREGIT2",226,0) + .. Q:'$$ST(N) +"RTN","VWREGIT2",227,0) + .. S AR($P(X,"^"),I)=$P(X,"^")_"("_N_")" +"RTN","VWREGIT2",228,0) + . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X +"RTN","VWREGIT2",229,0) + . K AR +"RTN","VWREGIT2",230,0) + . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1) +"RTN","VWREGIT2",231,0) + I $L(XHOW,"^")>1,$P(XHOW,"^")="NS" D Q +"RTN","VWREGIT2",232,0) + . S RESULT(0)="Templates by Namespace: " +"RTN","VWREGIT2",233,0) + . S N=$P(XHOW,"^",2) F I=1:1 S N=$O(^DIE("B",N)) Q:N'[$P(XHOW,"^",2) S AR(N,I)=N_"("_$O(^DIE("B",N,0))_")" +"RTN","VWREGIT2",234,0) + . S X="AR" F S X=$Q(@X) Q:X="" S Y=@X S:$$ST(+$P(Y,"(",2)) RESULT($$INR)=Y +"RTN","VWREGIT2",235,0) + . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1) +"RTN","VWREGIT2",236,0) + I $L(XHOW,"^")>1,$P(XHOW,"^")="U",+$P(XHOW,"^",2) D Q +"RTN","VWREGIT2",237,0) + . S RESULT(0)="Templates from: " +"RTN","VWREGIT2",238,0) + . S USER=+$P(XHOW,"^",2) +"RTN","VWREGIT2",239,0) + . I '$D(^VA(200,USER)) S RESULT(0)="I Cannot ID that user number." Q +"RTN","VWREGIT2",240,0) + . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N S NAME=$P(^(N,0),"^") I $P(^(0),"^",5)=USER S AR(NAME,I)=NAME_"("_N_")" +"RTN","VWREGIT2",241,0) + . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X +"RTN","VWREGIT2",242,0) + . S $P(RESULT(0),": ",2)=$P(^VA(200,USER,0),"^")_" - "_$O(RESULT(" "),-1) +"RTN","VWREGIT2",243,0) + . K AR +"RTN","VWREGIT2",244,0) + I $L(XHOW,"^")>1,$P(XHOW,"^")="U",'+$P(XHOW,"^",2) D Q +"RTN","VWREGIT2",245,0) + . S NAME=$P(XHOW,"^",2) +"RTN","VWREGIT2",246,0) + . K LUERR,ARR D FIND^DIC(200,"",".01;","CM",NAME,"","B","","","ARR","LUERR") +"RTN","VWREGIT2",247,0) + . I $O(ARR("DILIST",2,1)) D Q +"RTN","VWREGIT2",248,0) + .. S RESULT(0)="LIST" +"RTN","VWREGIT2",249,0) + .. S RESULT(1)="[Instruction: double-click to select; right-click to close]" +"RTN","VWREGIT2",250,0) + .. S N=0 F S N=$O(ARR("DILIST",1,N)) Q:'+N S RESULT($$INR)=ARR("DILIST",2,N)_"^"_ARR("DILIST",1,N) +"RTN","VWREGIT2",251,0) + . S IEN=ARR("DILIST",2,1) K ARR +"RTN","VWREGIT2",252,0) + . S RESULT(0)="Templates from: " +"RTN","VWREGIT2",253,0) + . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N!('$$ST(N)) S X=^(N,0) S:$P(X,"^",5)=IEN AR($P(X,"^"),I)=$P(X,"^")_"("_N_")" +"RTN","VWREGIT2",254,0) + . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X +"RTN","VWREGIT2",255,0) + . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1) +"RTN","VWREGIT2",256,0) + . K AR +"RTN","VWREGIT2",257,0) + Q +"RTN","VWREGIT2",258,0) + ; +"RTN","VWREGIT2",259,0) + +"RTN","VWREGIT3") +0^10^B43452100 +"RTN","VWREGIT3",1,0) +VWREGIT ;VWEHR/BFProd-Jim Bell, et al - World VistA GUI Pat Reg Utility +"RTN","VWREGIT3",2,0) + ;;1.0;WORLD VISTA;** **;;Build 1 +"RTN","VWREGIT3",3,0) + ; +"RTN","VWREGIT3",4,0) + ;This routine utility is for patient specific fields and +"RTN","VWREGIT3",5,0) + ;is used to build input templates for registration +"RTN","VWREGIT3",6,0) + ; +"RTN","VWREGIT3",7,0) + ;GNU License: See WVLIC.txt +"RTN","VWREGIT3",8,0) + ;Modified FOIA VISTA, +"RTN","VWREGIT3",9,0) + ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU +"RTN","VWREGIT3",10,0) + Q +"RTN","VWREGIT3",11,0) + ; +"RTN","VWREGIT3",12,0) +PREFLAB ;Preferred label extract +"RTN","VWREGIT3",13,0) + N FIELD,LABEL,N,I,CUSLAB +"RTN","VWREGIT3",14,0) + S N=0 F S N=$O(RESULT(N)) Q:'+N D +"RTN","VWREGIT3",15,0) + . S LABEL=$P(RESULT(N),"^") +"RTN","VWREGIT3",16,0) + . S FIELD=$P(RESULT(N),"^",2) +"RTN","VWREGIT3",17,0) + . S I=0 F S I=$O(AR(I)) Q:'+I D:RESULT(N)'[";" +"RTN","VWREGIT3",18,0) + .. Q:AR(I)'[";" +"RTN","VWREGIT3",19,0) + .. I $P(AR(I),";")=LABEL!($P(AR(I),";")=FIELD) D +"RTN","VWREGIT3",20,0) + ... S CUSLAB=$P(AR(I),";",2) +"RTN","VWREGIT3",21,0) + ... S CUSLAB=$TR(CUSLAB,"""","") +"RTN","VWREGIT3",22,0) + ... S $P(RESULT(N),"^")=CUSLAB +"RTN","VWREGIT3",23,0) + Q +"RTN","VWREGIT3",24,0) + ; +"RTN","VWREGIT3",25,0) +PARSE(STRING) ;Extract necessary data components in the string +"RTN","VWREGIT3",26,0) + N VAL,PIECE,LABEL,PREFLAB,FLDSN +"RTN","VWREGIT3",27,0) + S VAL=-1 I STRING="" G POUT +"RTN","VWREGIT3",28,0) + ;I $E(STRING)=">" S VAL="" G POUT +"RTN","VWREGIT3",29,0) + S PIECE=$S(STRING["(Multiple)":2,$L(STRING,"(")>2:3,1:2) +"RTN","VWREGIT3",30,0) + I $E(STRING)=">" D G POUT +"RTN","VWREGIT3",31,0) + . S SUBF=+$P(STRING,";",2),MAR(SUBF)="" +"RTN","VWREGIT3",32,0) + . S MAR(SUBF)=MAR(SUBF)_+$P(STRING,"(",PIECE) +"RTN","VWREGIT3",33,0) + . S VAL="" +"RTN","VWREGIT3",34,0) + S LABEL=$P(STRING,"~") +"RTN","VWREGIT3",35,0) + S PREFLAB=$S($P(STRING,"~",2)="(Multiple)":"",1:$P(STRING,"~",2)) +"RTN","VWREGIT3",36,0) + S FLDN=+$P(STRING,"(",PIECE) +"RTN","VWREGIT3",37,0) + I '+FLDN,$G(DUZ(0))="@" S VAL=STRING G POUT +"RTN","VWREGIT3",38,0) + S VAL=FLDN_PREFLAB_"~"_$S('$L(PREFLAB):"",1:$P(LABEL,"(",1,PIECE-1)_"^"_PREFLAB) +"RTN","VWREGIT3",39,0) +POUT Q VAL +"RTN","VWREGIT3",40,0) + ; +"RTN","VWREGIT3",41,0) +NEXT(XAR) ;Get next subscript +"RTN","VWREGIT3",42,0) + Q $O(XAR(" "),-1)+1 +"RTN","VWREGIT3",43,0) + ; +"RTN","VWREGIT3",44,0) +REJECT(FIELD,IEN) ;Reject Asterisked and Computed fields +"RTN","VWREGIT3",45,0) + I FIELD["COMPONENTS" Q 1 ;Pain in the butt! +"RTN","VWREGIT3",46,0) + I $E(FIELD)="*" Q 1 ;field marked for deletion +"RTN","VWREGIT3",47,0) + I $E($P($G(^DD(2,IEN,0)),"^",2))="C" Q 1 ;computed field +"RTN","VWREGIT3",48,0) + Q 0 ;Passed +"RTN","VWREGIT3",49,0) + ; +"RTN","VWREGIT3",50,0) +GTNUM ; +"RTN","VWREGIT3",51,0) + K AR,RESULT S RESULT(0)=-1 +"RTN","VWREGIT3",52,0) + M AR=^DIE(TNUM) +"RTN","VWREGIT3",53,0) + Q:'$D(AR(0)) ;Huh, no template? +"RTN","VWREGIT3",54,0) + S RESULT(0)=TNAME +"RTN","VWREGIT3",55,0) + S FLDS=AR("DR",1,2) +"RTN","VWREGIT3",56,0) + F I=1:1:$L(FLDS,";")-1 S FN=$P(FLDS,";",I) D +"RTN","VWREGIT3",57,0) + . S FDATA=$S(+FN:$P(^DD(2,FN,0),"^",1,2),1:FN) +"RTN","VWREGIT3",58,0) + . S RESULT($$NEXT(.RESULT))=$S(+FN:$P(FDATA,"^")_"("_FN_")",1:FN)_$S(+$P(FDATA,"^",2):"~(Multiple)",1:"") +"RTN","VWREGIT3",59,0) + . I +$P(FDATA,"^",2) S SFN=AR("DR",2,+$P(FDATA,"^",2)) D +"RTN","VWREGIT3",60,0) + .. F J=1:1:$L(SFN,";")-1 D +"RTN","VWREGIT3",61,0) + ... S SDF=$P(SFN,";",J) +"RTN","VWREGIT3",62,0) + ... S SDFDATA=$P(^DD(+$P(FDATA,"^",2),+SDF,0),"^",1,2) +"RTN","VWREGIT3",63,0) + ... S RESULT($$NEXT(.RESULT))=">>>>> "_$P(SDFDATA,"^")_"("_SDF_";"_+$P(FDATA,"^",2)_")"_$S(+$P(SDFDATA,"^",2):"~(Multiple)",1:"") +"RTN","VWREGIT3",64,0) + ... I +$P(SDFDATA,"^",2) S SF3=AR("DR",2,+$P(SDFDATA,"^",2)) D +"RTN","VWREGIT3",65,0) + .... F K=1:1:$L(SF3,";")-1 S SF3DATA=$P(^DD(+$P(SDFDATA,"^",2),SF3,0),"^",1,2) D +"RTN","VWREGIT3",66,0) + ..... S RESULT($$NEXT(.RESULT))=">>>>>>>>>> "_SF3_"~"_$P(SF3DATA,"^")_$S(+$P(SF3DATA,"^",2):"~(Multiple)",1:"") +"RTN","VWREGIT3",67,0) + Q +"RTN","VWREGIT3",68,0) + ; +"RTN","VWREGIT3",69,0) +NFT(SUBS) ;Patient file fields into scratch global +"RTN","VWREGIT3",70,0) + Q $O(^UTILITY(SUBS," "),-1)+1 ;Next suscript +"RTN","VWREGIT3",71,0) + ; +"RTN","VWREGIT3",72,0) +SD ;SUB-DICS +"RTN","VWREGIT3",73,0) + N N,FLD,X +"RTN","VWREGIT3",74,0) + K ^UTILITY("SFT") +"RTN","VWREGIT3",75,0) + S X="^DD(2,""SB"")" +"RTN","VWREGIT3",76,0) + F S X=$Q(@X) Q:X'["SB" D +"RTN","VWREGIT3",77,0) + . S N=+$P(X,",",3) +"RTN","VWREGIT3",78,0) + . S FLD=+$P(X,",",4) +"RTN","VWREGIT3",79,0) + . S ^UTILITY("SFT",FLD,N)="" +"RTN","VWREGIT3",80,0) + Q +"RTN","VWREGIT3",81,0) + ; +"RTN","VWREGIT3",82,0) +LF(RESULT,TNAME) ;Full list of patient fields +"RTN","VWREGIT3",83,0) + K RESULT +"RTN","VWREGIT3",84,0) + S TNUM=+$P(TNAME,"(",2) D:TNUM GTNUM ;Existing template +"RTN","VWREGIT3",85,0) + ; Add patient file fields +"RTN","VWREGIT3",86,0) + S RESULT($$NEXT(.RESULT))="[PF]" +"RTN","VWREGIT3",87,0) + K ^UTILITY("FT") D SD +"RTN","VWREGIT3",88,0) + S FLD="" F S FLD=$O(^DD(2,"B",FLD)) Q:FLD="" D +"RTN","VWREGIT3",89,0) + . S N=0 F S N=$O(^DD(2,"B",FLD,N)) Q:'+N D:'$$REJECT(FLD,N) +"RTN","VWREGIT3",90,0) + .. S ^UTILITY("FT",$$NFT("FT"))=FLD_"("_N_")"_"~"_$S($D(^UTILITY("SFT",N)):"(Multiple)",1:" ") +"RTN","VWREGIT3",91,0) + .. S SDD=$O(^UTILITY("SFT",N,0)) Q:'SDD +"RTN","VWREGIT3",92,0) + .. S SDFLD="" F S SDFLD=$O(^DD(SDD,"B",SDFLD)) Q:SDFLD="" D +"RTN","VWREGIT3",93,0) + ... S SDN=0 F S SDN=$O(^DD(SDD,"B",SDFLD,SDN)) Q:'+SDN I '$$REJECT(SDFLD,SDN) S ^UTILITY("FT",$$NFT("FT"))=">>>>> "_SDFLD_"("_SDN_";"_SDD_")" +"RTN","VWREGIT3",94,0) + K ^UTILITY("SFT") +"RTN","VWREGIT3",95,0) + I '$O(^UTILITY("FT",0)) Q +"RTN","VWREGIT3",96,0) + S X="^UTILITY(""FT"")" +"RTN","VWREGIT3",97,0) + F I=1:1 S X=$Q(@X) Q:X'["FT" S RESULT($$NEXT(.RESULT))=@X +"RTN","VWREGIT3",98,0) + K ^UTILITY("FT") +"RTN","VWREGIT3",99,0) + Q +"RTN","VWREGIT3",100,0) + ; +"RTN","VWREGIT3",101,0) +SAVE(RESULT,FLDS) ; +"RTN","VWREGIT3",102,0) + ;W " ;Intentional "Instantiated" Screw Job +"RTN","VWREGIT3",103,0) + Q:'$D(FLDS) +"RTN","VWREGIT3",104,0) + K ^UTILITY("FLDS") M ^UTILITY("FLDS")=FLDS +"RTN","VWREGIT3",105,0) + N TNUM,TNAME,DIC,DATA,FX,N,X,Y,DIE,NEWTEMP,PIECE +"RTN","VWREGIT3",106,0) + ;Clean FLDS or subscripts with empty values +"RTN","VWREGIT3",107,0) + I '$L(FLDS(0)) K FLDS(0) +"RTN","VWREGIT3",108,0) + S N=0 F S N=$O(FLDS(N)) Q:'+N D +"RTN","VWREGIT3",109,0) + . I '$L(FLDS(N)) K FLDS(N) +"RTN","VWREGIT3",110,0) + . S Y=$P(FLDS(N),"~",2) +"RTN","VWREGIT3",111,0) + . I $E(Y)=" " S $P(FLDS(N),"~",2)=$P(Y," ",2) +"RTN","VWREGIT3",112,0) + ;End cleaning +"RTN","VWREGIT3",113,0) + S NEWTEMP=0 +"RTN","VWREGIT3",114,0) + S TNUM=+$P(FLDS(0),"(",2) +"RTN","VWREGIT3",115,0) + I 'TNUM S TNAME=$P(FLDS(0),"(") +"RTN","VWREGIT3",116,0) + S TNUM=$O(^DIE("B",TNAME,0)) +"RTN","VWREGIT3",117,0) + I 'TNUM K DATA D ;File a new entry +"RTN","VWREGIT3",118,0) + . D NOW^%DTC +"RTN","VWREGIT3",119,0) + . S DIC="^DIE(" +"RTN","VWREGIT3",120,0) + . S DATA(.402,"+1,",.01)=TNAME +"RTN","VWREGIT3",121,0) + . S DATA(.402,"+1,",2)=% +"RTN","VWREGIT3",122,0) + . S DATA(.402,"+1,",3)=$G(DUZ(0)) +"RTN","VWREGIT3",123,0) + . S DATA(.402,"+1,",4)=2 +"RTN","VWREGIT3",124,0) + . S DATA(.402,"+1,",5)=DUZ +"RTN","VWREGIT3",125,0) + . S DATA(.402,"+1,",6)=$G(DUZ(0)) +"RTN","VWREGIT3",126,0) + . D UPDATE^DIE("","DATA","IEN","ERR") +"RTN","VWREGIT3",127,0) + . S TNUM=IEN(1) D RECALL^DILFD(.402,TNUM_",",DUZ) +"RTN","VWREGIT3",128,0) + . S NEWTEMP=1 +"RTN","VWREGIT3",129,0) + ;Primary fields +"RTN","VWREGIT3",130,0) + ;K DATA,^DIE(TNUM,"DR") +"RTN","VWREGIT3",131,0) + K DATA,^UTILITY("DIETED",$J),^UTILITY("DIETEDIAB",$J) +"RTN","VWREGIT3",132,0) + K AR S N=0 F S N=$O(FLDS(N)) Q:'+N S X=$$PARSE(FLDS(N)) S:$L(X) AR(N)=X +"RTN","VWREGIT3",133,0) + S FX="",N=0 F S N=$O(AR(N)) Q:'+N D +"RTN","VWREGIT3",134,0) + . I AR(N)'["~" S FX=FX_AR(N)_";" Q +"RTN","VWREGIT3",135,0) + . S FLDN=+$P(AR(N),"~") +"RTN","VWREGIT3",136,0) + . S PREFLAB=$P($P(AR(N),FLDN,2),"~") +"RTN","VWREGIT3",137,0) + . S FX=FX_FLDN_$S($L(PREFLAB):PREFLAB_"~",1:"")_";" +"RTN","VWREGIT3",138,0) + S ^UTILITY("DIETED",$J,1,2)=FX +"RTN","VWREGIT3",139,0) + ;Set up the preferred labels +"RTN","VWREGIT3",140,0) + S N=0 F S N=$O(AR(N)) Q:'+N D +"RTN","VWREGIT3",141,0) + . S LABS=$P(AR(N),"~",2) Q:'$L(LABS) +"RTN","VWREGIT3",142,0) + . S ^UTILITY("DIETEDIAB",$J,N,0,2,0)=$P(LABS,"^")_";"_""""_$P(LABS,"^",2)_"""" +"RTN","VWREGIT3",143,0) + Q ;TESTING +"RTN","VWREGIT3",144,0) + ;Sub-fields of primaries +"RTN","VWREGIT3",145,0) + K AR +"RTN","VWREGIT3",146,0) + S N=0 F S N=$O(FLDS(N)) Q:'+N Q:$E(FLDS(N))=">" +"RTN","VWREGIT3",147,0) + G REGIT:'+N ;No sub-fields found for primaries +"RTN","VWREGIT3",148,0) + S N=$G(N)-1 F S N=$O(FLDS(N)) Q:'+N D:$E(FLDS(N))=">" +"RTN","VWREGIT3",149,0) + . S PIECE=$L(FLDS(N),"(") +"RTN","VWREGIT3",150,0) + . S X=$P($P(FLDS(N),"(",PIECE),")") +"RTN","VWREGIT3",151,0) + . S SUBDIC=+$P(X,";",2),SUBFLD=+$P(X,";") +"RTN","VWREGIT3",152,0) + . I '$D(AR(SUBDIC)) S AR(SUBDIC)="" +"RTN","VWREGIT3",153,0) + . S AR(SUBDIC)=AR(SUBDIC)_SUBFLD_";" +"RTN","VWREGIT3",154,0) + M ^DIE(TNUM,"DR",2)=AR +"RTN","VWREGIT3",155,0) +REGIT I NEWTEMP D ;Update HD/regit.txt +"RTN","VWREGIT3",156,0) + . S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY") +"RTN","VWREGIT3",157,0) + . S FILE="regit.txt" +"RTN","VWREGIT3",158,0) + . S P4=1 +"RTN","VWREGIT3",159,0) + . S P5="" +"RTN","VWREGIT3",160,0) + . S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5) +"RTN","VWREGIT3",161,0) + . S N=0 F S N=$O(AR(N)) Q:'+N Q:AR(N)["[ID" +"RTN","VWREGIT3",162,0) + . K AR(N) S AR(N)=TNAME_"("_IEN(1)_")" +"RTN","VWREGIT3",163,0) + . S AR(N+1)="[ID]" +"RTN","VWREGIT3",164,0) + . ZWR AR +"RTN","VWREGIT3",165,0) + . S X=$$GTF^%ZISH($NA(AR(1)),1,HD,"regit.txt") +"RTN","VWREGIT3",166,0) +SOUT S RESULT(0)=$S($G(IEN(1)):TNAME_"("_IEN(1)_")",1:-1) +"RTN","VWREGIT3",167,0) + Q +"RTN","VWREGIT3",168,0) + ; +"RTN","VWREGIT3",169,0) +HELP(RESULT,DATA) ;Get help for Fileman Fields +"RTN","VWREGIT3",170,0) + ; *************************************************** +"RTN","VWREGIT3",171,0) + ; *Incoming DATA__FILE^IEN[O]^FIELD^FLAGS^MSG_ROOT) * +"RTN","VWREGIT3",172,0) + ; *************************************************** +"RTN","VWREGIT3",173,0) + K RESULT,@$P(DATA,"^",5) +"RTN","VWREGIT3",174,0) + N FILE,IEN,FLD,FLAGS,X +"RTN","VWREGIT3",175,0) + S X="FILE^IEN^FLD^FLAGS" +"RTN","VWREGIT3",176,0) + F I=1:1:4 S @$P(X,"^",I)=$P(DATA,"^",I) +"RTN","VWREGIT3",177,0) + D HELP^DIE(FILE,IEN,FLD,FLAGS,$P(DATA,"^",5)) +"RTN","VWREGIT3",178,0) + F I=1:1:AR("DIHELP") S RESULT(I)=AR("DIHELP",I) +"RTN","VWREGIT3",179,0) + K @$P(DATA,"^",5),DATA +"RTN","VWREGIT3",180,0) + Q +"RTN","VWREGIT3",181,0) + ; +"RTN","VWREGIT3",182,0) +FP(RESULT,FLDS) ;Disassociated kids +"RTN","VWREGIT3",183,0) + ;W " ;Intentional "instantiated" failure +"RTN","VWREGIT3",184,0) + K RESULT,PAR +"RTN","VWREGIT3",185,0) + N N,FIELD,SUBDIC,PARENT,X +"RTN","VWREGIT3",186,0) + S N=0 F S N=$O(FLDS(N)) Q:'+N D:$E(FLDS(N))=">" +"RTN","VWREGIT3",187,0) + . S FIELD=$P($P(FLDS(N),"(",2),";") +"RTN","VWREGIT3",188,0) + . S SUBDIC=$P($P(FLDS(N),";",2),")") +"RTN","VWREGIT3",189,0) + . S PARENT=$O(^DD(2,"SB",SUBDIC,0)) +"RTN","VWREGIT3",190,0) + . Q:'PARENT +"RTN","VWREGIT3",191,0) + . S PAR(PARENT)=$P(^DD(2,PARENT,0),"^")_"("_PARENT_")~(Multiple)" +"RTN","VWREGIT3",192,0) + . S PAR(PARENT,$O(PAR(PARENT," "),-1)+1)=FLDS(N) +"RTN","VWREGIT3",193,0) + . K FLDS(N) +"RTN","VWREGIT3",194,0) + S X="PAR" F S X=$Q(@X) Q:X="" S FLDS($$NEXT(.FLDS))=@X +"RTN","VWREGIT3",195,0) + K PAR +"RTN","VWREGIT3",196,0) + S N=0 F S N=$O(FLDS(N)) Q:'+N S RESULT($$NEXT(.RESULT))=FLDS(N) +"RTN","VWREGIT3",197,0) + K FLDS +"RTN","VWREGIT3",198,0) + Q +"RTN","VWREGIT3",199,0) + ; +"RTN","VWREGIT4") +0^11^B43791810 +"RTN","VWREGIT4",1,0) +VWREGIT4 ;VWEHR/BFPro-Jim Bell, et al-World VistA Patient Registration Utility +"RTN","VWREGIT4",2,0) + ;;1.0;WorldVistA;BellFelder Productions;** **;Build 1; +"RTN","VWREGIT4",3,0) + ; +"RTN","VWREGIT4",4,0) + ;This routine utility is for all known patient data fields +"RTN","VWREGIT4",5,0) + ; +"RTN","VWREGIT4",6,0) + ;GNU License: See WVLIC.txt +"RTN","VWREGIT4",7,0) + ;Modified FOIA VISTA, +"RTN","VWREGIT4",8,0) + ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU +"RTN","VWREGIT4",9,0) + Q +"RTN","VWREGIT4",10,0) + ; +"RTN","VWREGIT4",11,0) +INR() Q $O(RESULT(" "),-1)+1 +"RTN","VWREGIT4",12,0) + ; +"RTN","VWREGIT4",13,0) +CLEAN ;Remove VA Specific nodes +"RTN","VWREGIT4",14,0) + ;S X="AR" F S X=$Q(@X) Q:X="" I $P(X,",",$L(X,",")-1)["