KIDS Distribution saved on Feb 04, 2004@10:56:17 DG*5.3*541 **KIDS**:DG*5.3*541^ **INSTALL NAME** DG*5.3*541 "BLD",4986,0) DG*5.3*541^REGISTRATION^0^3040204^y "BLD",4986,1,0) ^^10^10^3040116^ "BLD",4986,1,1,0) This allows pick lists to return entries beyond those that match the "BLD",4986,1,2,0) user's input exactly. With the fuzzy lookups in place a bill number "BLD",4986,1,3,0) such as K301EL2 may also return patients whose names begin with KEL. "BLD",4986,1,4,0) This has an unexpected result on the AR options when the user "BLD",4986,1,5,0) entered bill numbers. "BLD",4986,1,6,0) "BLD",4986,1,7,0) With this patch an Integration Agreement for the Accounts Receivable "BLD",4986,1,8,0) software package has been approved, this will allow for the correction to "BLD",4986,1,9,0) the patient fuzzy lookup that has caused sites to have problems when "BLD",4986,1,10,0) entering a patient or a bill number. "BLD",4986,4,0) ^9.64PA^^ "BLD",4986,"KRN",0) ^9.67PA^8989.52^19 "BLD",4986,"KRN",.4,0) .4 "BLD",4986,"KRN",.401,0) .401 "BLD",4986,"KRN",.402,0) .402 "BLD",4986,"KRN",.403,0) .403 "BLD",4986,"KRN",.5,0) .5 "BLD",4986,"KRN",.84,0) .84 "BLD",4986,"KRN",3.6,0) 3.6 "BLD",4986,"KRN",3.8,0) 3.8 "BLD",4986,"KRN",9.2,0) 9.2 "BLD",4986,"KRN",9.8,0) 9.8 "BLD",4986,"KRN",9.8,"NM",0) ^9.68A^1^1 "BLD",4986,"KRN",9.8,"NM",1,0) DPTLK^^0^B61613900 "BLD",4986,"KRN",9.8,"NM","B","DPTLK",1) "BLD",4986,"KRN",19,0) 19 "BLD",4986,"KRN",19,"NM",0) ^9.68A^^ "BLD",4986,"KRN",19.1,0) 19.1 "BLD",4986,"KRN",101,0) 101 "BLD",4986,"KRN",409.61,0) 409.61 "BLD",4986,"KRN",771,0) 771 "BLD",4986,"KRN",870,0) 870 "BLD",4986,"KRN",8989.51,0) 8989.51 "BLD",4986,"KRN",8989.52,0) 8989.52 "BLD",4986,"KRN",8994,0) 8994 "BLD",4986,"KRN","B",.4,.4) "BLD",4986,"KRN","B",.401,.401) "BLD",4986,"KRN","B",.402,.402) "BLD",4986,"KRN","B",.403,.403) "BLD",4986,"KRN","B",.5,.5) "BLD",4986,"KRN","B",.84,.84) "BLD",4986,"KRN","B",3.6,3.6) "BLD",4986,"KRN","B",3.8,3.8) "BLD",4986,"KRN","B",9.2,9.2) "BLD",4986,"KRN","B",9.8,9.8) "BLD",4986,"KRN","B",19,19) "BLD",4986,"KRN","B",19.1,19.1) "BLD",4986,"KRN","B",101,101) "BLD",4986,"KRN","B",409.61,409.61) "BLD",4986,"KRN","B",771,771) "BLD",4986,"KRN","B",870,870) "BLD",4986,"KRN","B",8989.51,8989.51) "BLD",4986,"KRN","B",8989.52,8989.52) "BLD",4986,"KRN","B",8994,8994) "BLD",4986,"PRE") "BLD",4986,"QUES",0) ^9.62^^ "BLD",4986,"REQB",0) ^9.611^1^1 "BLD",4986,"REQB",1,0) DG*5.3*528^2 "BLD",4986,"REQB","B","DG*5.3*528",1) "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,20,0) ^9.402P^^ "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 541^3040204^2447 "PKG",5,22,1,"PAH",1,1,0) ^^10^10^3040204 "PKG",5,22,1,"PAH",1,1,1,0) This allows pick lists to return entries beyond those that match the "PKG",5,22,1,"PAH",1,1,2,0) user's input exactly. With the fuzzy lookups in place a bill number "PKG",5,22,1,"PAH",1,1,3,0) such as K301EL2 may also return patients whose names begin with KEL. "PKG",5,22,1,"PAH",1,1,4,0) This has an unexpected result on the AR options when the user "PKG",5,22,1,"PAH",1,1,5,0) entered bill numbers. "PKG",5,22,1,"PAH",1,1,6,0) "PKG",5,22,1,"PAH",1,1,7,0) With this patch an Integration Agreement for the Accounts Receivable "PKG",5,22,1,"PAH",1,1,8,0) software package has been approved, this will allow for the correction to "PKG",5,22,1,"PAH",1,1,9,0) the patient fuzzy lookup that has caused sites to have problems when "PKG",5,22,1,"PAH",1,1,10,0) entering a patient or a bill number. "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") YES "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") YES "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") YES "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") 1 "RTN","DPTLK") 0^1^B61613900 "RTN","DPTLK",1,0) DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ; 05/13/2003 2:20 PM "RTN","DPTLK",2,0) ;;5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541**;Aug 13, 1993 "RTN","DPTLK",3,0) ; "RTN","DPTLK",4,0) ; mods made for magstripe read 12/96 - JFP "RTN","DPTLK",5,0) ; "RTN","DPTLK",6,0) ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented "RTN","DPTLK",7,0) ; by patch DG*5.3*244 "RTN","DPTLK",8,0) ; "RTN","DPTLK",9,0) EN ; -- Entry point "RTN","DPTLK",10,0) K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D(X))) "RTN","DPTLK",11,0) I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined." G QK "RTN","DPTLK",12,0) I '$D(^DPT(0))!(^DD("VERSION")<17.2) W !!?3,"Unable to proceed. ",$S('$D(^DPT(0)):"0th node of ^DPT missing",^DD("VERSION")<17.2:"Fileman version must be at least 17.2",1:""),"." G QK "RTN","DPTLK",13,0) EN2 K DO,DUOUT,DTOUT S U="^",DIC="^DPT(",DIC(0)=$S($D(DIC(0)):DIC(0),1:"AELMQ") S:DIC(0)'["A" (DPTX,DPTSAVX)=X "RTN","DPTLK",14,0) S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2):$P(^(0),U,2),1:DPTSZ) "RTN","DPTLK",15,0) ; "RTN","DPTLK",16,0) ASKPAT ; -- Prompt for patient "RTN","DPTLK",17,0) I DIC(0)["A" D G QK:'$T!($E(DPTX)["^")!(DPTX="") "RTN","DPTLK",18,0) .K DTOUT,DUOUT "RTN","DPTLK",19,0) .W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") W:$D(DIC("B")) DIC("B"),"// " "RTN","DPTLK",20,0) .R X:DTIME "RTN","DPTLK",21,0) .S DPTX=X S:'$T DTOUT=1 S:$T&(DPTX="")&($D(DIC("B"))) DPTX=DIC("B") S:DPTX["^" DUOUT=1 "RTN","DPTLK",22,0) ; -- Check for the IATA magnetic stripe input "RTN","DPTLK",23,0) N MAG,GCHK "RTN","DPTLK",24,0) S MAG=0 "RTN","DPTLK",25,0) I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?" S MAG=1,(X,DPTX)=$$IATA(DPTX) "RTN","DPTLK",26,0) ; "RTN","DPTLK",27,0) CHKPAT ; -- Custom Patient Lookup "RTN","DPTLK",28,0) D DO^DIC1 "RTN","DPTLK",29,0) S DIC("W")=$S($D(DIC("W")):DIC("W"),1:"") "RTN","DPTLK",30,0) K DPTIFNS,DPTS,DPTSEL "RTN","DPTLK",31,0) S DPTCNT=0 "RTN","DPTLK",32,0) ; -- Check input for format an length "RTN","DPTLK",33,0) G CHKDFN:DPTX?1A!(DPTX'?.ANP)!($L(DPTX)>30) "RTN","DPTLK",34,0) ; -- Check for null response or abort "RTN","DPTLK",35,0) I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",QK "RTN","DPTLK",36,0) ; -- Check for question mark "RTN","DPTLK",37,0) I DPTX["?" D G ASKPAT:DIC(0)["A",QK "RTN","DPTLK",38,0) .S D="B" "RTN","DPTLK",39,0) .S DZ=$S(DPTX?1"?":"",1:"??") "RTN","DPTLK",40,0) .G CHKPAT1:DZ="??" "RTN","DPTLK",41,0) .N % "RTN","DPTLK",42,0) .W !,?1,"Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits",!,?4,"of SOCIAL SECURITY NUMBER, or first initial of" "RTN","DPTLK",43,0) .W " last name with last",!,?4,"4 digits of SOCIAL SECURITY NUMBER" "RTN","DPTLK",44,0) .W !,?1,"Do you want the entire ",+$P($G(^DPT(0)),"^",4),"-Entry PATIENT List" S %=0 D YN^DICN "RTN","DPTLK",45,0) .Q:%'=1 "RTN","DPTLK",46,0) .S DZ="??" "RTN","DPTLK",47,0) CHKPAT1 .S X=DPTX "RTN","DPTLK",48,0) .D DQ^DICQ "RTN","DPTLK",49,0) ; -- Check for space bar, return "RTN","DPTLK",50,0) I DPTX=" " D G CHKDFN "RTN","DPTLK",51,0) .S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1) "RTN","DPTLK",52,0) .D SETDPT^DPTLK1:Y>0 "RTN","DPTLK",53,0) .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) "RTN","DPTLK",54,0) ; -- Check for DFN look up "RTN","DPTLK",55,0) I $E(DPTX)="`" D G CHKDFN "RTN","DPTLK",56,0) .S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1) "RTN","DPTLK",57,0) .D SETDPT^DPTLK1:Y>0 "RTN","DPTLK",58,0) .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) "RTN","DPTLK",59,0) ; -- Puts input in correct format "RTN","DPTLK",60,0) G CHKDFN:DPTX="" "RTN","DPTLK",61,0) ; -- Force new entry "RTN","DPTLK",62,0) I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" G NOPAT "RTN","DPTLK",63,0) ; -- Check for index lookups "RTN","DPTLK",64,0) D ^DPTLK1 G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D(DUOUT),CHKPAT:DPTDFN<0,CHKDFN:DPTDFN>0 I DIC(0)["N",$D(^DPT(DPTX,0)) S Y=X D SETDPT^DPTLK1 S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) G CHKDFN "RTN","DPTLK",65,0) MAG ; -- No patient found, check for mag stripe input, create stub "RTN","DPTLK",66,0) I 'MAG G NOPAT "RTN","DPTLK",67,0) ; -- Check for ADT option(s) only "RTN","DPTLK",68,0) N DGOPT "RTN","DPTLK",69,0) S DGOPT=$P($G(XQY0),"^",2) "RTN","DPTLK",70,0) I DGOPT'="Load/Edit Patient Data",DGOPT'="Register a Patient" D G EN2 "RTN","DPTLK",71,0) .W !," ...Patient not in database, use ADT options to load patient" D Q1 "RTN","DPTLK",72,0) ; -- Prompt for creation of stub "RTN","DPTLK",73,0) S DIR(0)="Y",DIR("B")="NO",DIR("A")="Patient not found...Create stub entry: " "RTN","DPTLK",74,0) S GCHK=$D(^TMP("DGVIC")) "RTN","DPTLK",75,0) D ^DIR "RTN","DPTLK",76,0) K DIR "RTN","DPTLK",77,0) I 'Y D Q1 G EN2 "RTN","DPTLK",78,0) ; -- Parse IATA fields "RTN","DPTLK",79,0) D FIELDS(IATA) "RTN","DPTLK",80,0) ; -- Check for Duplicates "RTN","DPTLK",81,0) D EP2^DPTLK3 "RTN","DPTLK",82,0) I DPTDFN<0 D Q1 G EN2 "RTN","DPTLK",83,0) ; -- Creates Stub entry in patient file "RTN","DPTLK",84,0) S Y=$$FILE^DPTLK4(DGFLDS) "RTN","DPTLK",85,0) I $P(Y,"^",3)'=1 W !,"Could not add patient to patient file" D QK1 Q "RTN","DPTLK",86,0) D QK1 "RTN","DPTLK",87,0) Q "RTN","DPTLK",88,0) ; "RTN","DPTLK",89,0) NOPAT ; -- No patient found, ask to add new "RTN","DPTLK",90,0) I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A"&(Y<0)&('$G(DTOUT)),QK1 "RTN","DPTLK",91,0) ; "RTN","DPTLK",92,0) CHKDFN ; -- "RTN","DPTLK",93,0) S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN))) W:DIC(0)["Q" *7," ??" G ASKPAT:DIC(0)["A",QK "RTN","DPTLK",94,0) I DIC(0)["E" D W $S('$D(DPTSEL)&('$D(DIVP)):$P(DPTS(DPTDFN),U,2)_" "_$P(DPTS(DPTDFN),U)_" ",$D(^DPT(DPTDFN,0)):" "_$P(^(0),U)_" ",1:"") S Y=DPTDFN X:$D(^DPT(DPTDFN,0)) "N DDS X DIC(""W"")" "RTN","DPTLK",95,0) .I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY "RTN","DPTLK",96,0) ; "RTN","DPTLK",97,0) ; check for other patients in "BS5" xref on Patient file "RTN","DPTLK",98,0) I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) D G ASKPAT:DIC(0)["A"&(%'=1),QK:DPTDFN<0 "RTN","DPTLK",99,0) .N DPTZERO,DPTLSNME,DPTSSN S DPTZERO=$G(^DPT(+DPTDFN,0)),DPTLSNME=$P($P(DPTZERO,U),","),DPTSSN=$E($P(DPTZERO,U,9),6,9) "RTN","DPTLK",100,0) .W $C(7),!!,"There is more than one patient whose last name is '",DPTLSNME,"' and" "RTN","DPTLK",101,0) .W !,"whose social security number ends with '",DPTSSN,"'." "RTN","DPTLK",102,0) .W !,"Are you sure you wish to continue (Y/N)" S %=0 D YN^DICN "RTN","DPTLK",103,0) .I %'=1 S DPTDFN=-1 "RTN","DPTLK",104,0) ; "RTN","DPTLK",105,0) I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0)["A"&(DPTDFN<0),QK:DPTDFN<0 "RTN","DPTLK",106,0) S DPTX=DPTX_$P(DPTS(DPTDFN),U,2),DPTDFN=DPTDFN_U_$P(^DPT(DPTDFN,0),U) "RTN","DPTLK",107,0) ; "RTN","DPTLK",108,0) Q ; -- "RTN","DPTLK",109,0) S Y=$S('$D(DPTDFN):-1,'$D(DPTS(+DPTDFN)):-1,1:DPTDFN),X=$S($D(DPTX)&(+Y>0):DPTX,$D(DPTSAVX):DPTSAVX,$D(DPTX):DPTX,1:"") "RTN","DPTLK",110,0) I Y>0 S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y S:DIC(0)["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1) "RTN","DPTLK",111,0) I DIC(0)["E",$P($G(^DPT(+Y,0)),U,21) W *7,!,"Warning : You have selected a test patient." "RTN","DPTLK",112,0) ;Display enrollment information "RTN","DPTLK",113,0) I Y>0,DIC(0)["E" D ENR "RTN","DPTLK",114,0) ; "RTN","DPTLK",115,0) ;Call Combat Vet check "RTN","DPTLK",116,0) I Y>0,DIC(0)["E" D CV "RTN","DPTLK",117,0) ; "RTN","DPTLK",118,0) ; check whether to display Means Test Required message "RTN","DPTLK",119,0) D "RTN","DPTLK",120,0) .N DPTDIV "RTN","DPTLK",121,0) .I '$G(DUZ(2)) Q "RTN","DPTLK",122,0) .I Y>0,DIC(0)["E" S DPTDIV=$$DMT^DPTLK5(+Y,DUZ(2)) I DPTDIV D "RTN","DPTLK",123,0) ..W $C(7),!!,"MEANS TEST REQUIRED" "RTN","DPTLK",124,0) ..W !,?3,$P($G(^DG(40.8,DPTDIV,"MT")),U,2) "RTN","DPTLK",125,0) ..H 2 "RTN","DPTLK",126,0) ; "RTN","DPTLK",127,0) Q1 ; -- Clean up variables "RTN","DPTLK",128,0) K D,DIC("W"),DO,DPTCNT,DPTDFN,DPTIFNS,DPTIX,DPTS "RTN","DPTLK",129,0) K DPTSAVX,DPTSEL,DPTSZ,DPTX "RTN","DPTLK",130,0) ; "RTN","DPTLK",131,0) K:$D(IATA) IATA "RTN","DPTLK",132,0) K:$D(DGFLDS) @DGFLDS,DGFLDS "RTN","DPTLK",133,0) Q "RTN","DPTLK",134,0) ; "RTN","DPTLK",135,0) QK K:'$D(DPTNOFZK) DPTNOFZY G Q "RTN","DPTLK",136,0) ; "RTN","DPTLK",137,0) QK1 K:'$D(DPTNOFZK) DPTNOFZY G Q1 "RTN","DPTLK",138,0) ; "RTN","DPTLK",139,0) IX ; -- "RTN","DPTLK",140,0) I $D(D),$D(^DD(2,0,"IX",D)),($E(D)'="A") S DPTIX=D "RTN","DPTLK",141,0) G DPTLK "RTN","DPTLK",142,0) ; "RTN","DPTLK",143,0) IATA(X) ; -- "RTN","DPTLK",144,0) ;This function pulls off ssn from the IATA track "RTN","DPTLK",145,0) ; "RTN","DPTLK",146,0) ;Input: X - what was read in "RTN","DPTLK",147,0) ;Output: SSN - social security number "RTN","DPTLK",148,0) ; Q - quit "RTN","DPTLK",149,0) ; "RTN","DPTLK",150,0) ; Track Start Sent End Sent Field Separator "RTN","DPTLK",151,0) ; ----- ---------- -------- --------------- "RTN","DPTLK",152,0) ; IATA (alphanum) % ? { (Note: VA used ^) "RTN","DPTLK",153,0) ; ABA (numeric) ; ? = "RTN","DPTLK",154,0) ; "RTN","DPTLK",155,0) ;N IATA "RTN","DPTLK",156,0) S (IATA)="" "RTN","DPTLK",157,0) I $E(X)'="%" Q X ; no start sentinel "RTN","DPTLK",158,0) I X'["?" Q "Q" "RTN","DPTLK",159,0) ; -- Extract data from track "RTN","DPTLK",160,0) S IATA=$$TRACK(X,"%","?") "RTN","DPTLK",161,0) ; -- checks for no data "RTN","DPTLK",162,0) I IATA="" Q "Q" "RTN","DPTLK",163,0) ; -- Returns SSN "RTN","DPTLK",164,0) I IATA'="" Q $P(IATA,"^") "RTN","DPTLK",165,0) Q "Q" "RTN","DPTLK",166,0) ; "RTN","DPTLK",167,0) TRACK(X,START,END) ; find track where start/end are sentinels "RTN","DPTLK",168,0) ; "RTN","DPTLK",169,0) Q $P($P($G(X),START,2),END,1) "RTN","DPTLK",170,0) ; "RTN","DPTLK",171,0) FIELDS(IATA) ; -- Sets fields "RTN","DPTLK",172,0) Q:'$D(IATA) "RTN","DPTLK",173,0) N CNT,FIELD "RTN","DPTLK",174,0) S DGFLDS="^TMP(""DGVIC"","_$J_")",CNT=1 "RTN","DPTLK",175,0) K @DGFLDS "RTN","DPTLK",176,0) F S FIELD=$P($G(IATA),"^",CNT) Q:FIELD="" D "RTN","DPTLK",177,0) .S @DGFLDS@(CNT)=FIELD "RTN","DPTLK",178,0) .S CNT=CNT+1 "RTN","DPTLK",179,0) ; -- Define fields for duplicate checker "RTN","DPTLK",180,0) S DPTX=$G(@DGFLDS@(2)) ;NAME "RTN","DPTLK",181,0) S DPTIDS(.03)=$G(@DGFLDS@(3)) ;DOB "RTN","DPTLK",182,0) S DPTIDS(.09)=$G(@DGFLDS@(1)) ;SSN "RTN","DPTLK",183,0) Q "RTN","DPTLK",184,0) ENR ;Display Enrollment information after patient selection "RTN","DPTLK",185,0) N DGENCAT,DGENDFN,DGENR,DGEGTIEN,DGEGT "RTN","DPTLK",186,0) I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) Q "RTN","DPTLK",187,0) S DGENCAT=$$CATEGORY^DGENA4(+DPTDFN) "RTN","DPTLK",188,0) S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT) "RTN","DPTLK",189,0) W !?1,"Enrollment Priority: ",$S($G(DGENR("PRIORITY")):$$EXT^DGENU("PRIORITY",DGENR("PRIORITY")),1:""),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT^DGENU("SUBGRP",$G(DGENR("SUBGRP")))) "RTN","DPTLK",190,0) W ?33,"Category: ",DGENCAT "RTN","DPTLK",191,0) W ?57,"End Date: ",$S($G(DGENR("END")):$$FMTE^XLFDT(DGENR("END"),"5DZ"),1:""),! "RTN","DPTLK",192,0) ;If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible Project Phase I) "RTN","DPTLK",193,0) I $G(DGENR("STATUS"))=10!($G(DGENR("STATUS"))=19)!($G(DGENR("STATUS"))=20) D "RTN","DPTLK",194,0) . W ?1,"Enrollment Status: ",$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"") ;H 5 "RTN","DPTLK",195,0) ;check for Combat Veteran Eligibility, if elig do not display EGT info "RTN","DPTLK",196,0) I $$CVEDT^DGCV(+DPTDFN) Q "RTN","DPTLK",197,0) ;Get Enrollment Group Threshold Priority and Subgroup "RTN","DPTLK",198,0) S DGEGTIEN=$$FINDCUR^DGENEGT "RTN","DPTLK",199,0) S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT) "RTN","DPTLK",200,0) Q:$G(DGENR("PRIORITY"))=""!($G(DGEGT("PRIORITY"))="") "RTN","DPTLK",201,0) ;Compare Patient's Enrollment Priority to Enrollment Group Threshold "RTN","DPTLK",202,0) I '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$G(DGENR("SUBGRP")),DGEGT("PRIORITY"),DGEGT("SUBGRP")) D "RTN","DPTLK",203,0) .N X,IORVOFF,IORVON "RTN","DPTLK",204,0) .S X="IORVOFF;IORVON" "RTN","DPTLK",205,0) .D ENDR^%ZISS "RTN","DPTLK",206,0) .W !?32 W:$D(IORVON) IORVON W "*** WARNING ***" W:$D(IORVOFF) IORVOFF "RTN","DPTLK",207,0) .I DGENR("END")'="" W !?14 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT END",$S(DT>+DGENR("END"):"ED",1:"S")," EFFECTIVE ",$$FMTE^XLFDT(DGENR("END"),"5DZ")," ***" W:$D(IORVOFF) IORVOFF Q "RTN","DPTLK",208,0) .W !?5 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT ENDING. ENROLLMENT END DATE IS NOT KNOWN. ***" W:$D(IORVOFF) IORVOFF "RTN","DPTLK",209,0) Q "RTN","DPTLK",210,0) CV ;check for Combat Vet status "RTN","DPTLK",211,0) N DGCV "RTN","DPTLK",212,0) S DGCV=$$CVEDT^DGCV(+DPTDFN) "RTN","DPTLK",213,0) I $P(DGCV,U)=1 D Q "RTN","DPTLK",214,0) . I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) W ! "RTN","DPTLK",215,0) . W ?3,"Combat Vet Status: "_$S($P(DGCV,U,2)>DT:"ELIGIBLE",1:"EXPIRED"),?57,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ") "RTN","DPTLK",216,0) Q "VER") 8.0^22 **END** **END**