Index: IRegistration/tag/1.0/VWGUIREG_UPDATE_03232014.KID =================================================================== --- /GUIRegistration/tag/1.0/VWGUIREG_UPDATE_03232014.KID (revision 1638) +++ (revision ) @@ -1,2082 +1,0 @@ -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)["