Released DG*5.3*581 SEQ #511 Extracted from mail message **KIDS**:DG*5.3*581^ **INSTALL NAME** DG*5.3*581 "BLD",5386,0) DG*5.3*581^REGISTRATION^0^3040512^y "BLD",5386,4,0) ^9.64PA^^ "BLD",5386,"KRN",0) ^9.67PA^8989.52^19 "BLD",5386,"KRN",.4,0) .4 "BLD",5386,"KRN",.401,0) .401 "BLD",5386,"KRN",.402,0) .402 "BLD",5386,"KRN",.403,0) .403 "BLD",5386,"KRN",.5,0) .5 "BLD",5386,"KRN",.84,0) .84 "BLD",5386,"KRN",3.6,0) 3.6 "BLD",5386,"KRN",3.8,0) 3.8 "BLD",5386,"KRN",9.2,0) 9.2 "BLD",5386,"KRN",9.8,0) 9.8 "BLD",5386,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",5386,"KRN",9.8,"NM",1,0) DGPREP0^^0^B25300465 "BLD",5386,"KRN",9.8,"NM",2,0) DGPREBJ^^0^B12768948 "BLD",5386,"KRN",9.8,"NM",3,0) DGREGAZL^^0^B37170348 "BLD",5386,"KRN",9.8,"NM","B","DGPREBJ",2) "BLD",5386,"KRN",9.8,"NM","B","DGPREP0",1) "BLD",5386,"KRN",9.8,"NM","B","DGREGAZL",3) "BLD",5386,"KRN",19,0) 19 "BLD",5386,"KRN",19.1,0) 19.1 "BLD",5386,"KRN",101,0) 101 "BLD",5386,"KRN",409.61,0) 409.61 "BLD",5386,"KRN",771,0) 771 "BLD",5386,"KRN",870,0) 870 "BLD",5386,"KRN",8989.51,0) 8989.51 "BLD",5386,"KRN",8989.52,0) 8989.52 "BLD",5386,"KRN",8994,0) 8994 "BLD",5386,"KRN","B",.4,.4) "BLD",5386,"KRN","B",.401,.401) "BLD",5386,"KRN","B",.402,.402) "BLD",5386,"KRN","B",.403,.403) "BLD",5386,"KRN","B",.5,.5) "BLD",5386,"KRN","B",.84,.84) "BLD",5386,"KRN","B",3.6,3.6) "BLD",5386,"KRN","B",3.8,3.8) "BLD",5386,"KRN","B",9.2,9.2) "BLD",5386,"KRN","B",9.8,9.8) "BLD",5386,"KRN","B",19,19) "BLD",5386,"KRN","B",19.1,19.1) "BLD",5386,"KRN","B",101,101) "BLD",5386,"KRN","B",409.61,409.61) "BLD",5386,"KRN","B",771,771) "BLD",5386,"KRN","B",870,870) "BLD",5386,"KRN","B",8989.51,8989.51) "BLD",5386,"KRN","B",8989.52,8989.52) "BLD",5386,"KRN","B",8994,8994) "BLD",5386,"QUES",0) ^9.62^^ "BLD",5386,"REQB",0) ^9.611^3^3 "BLD",5386,"REQB",1,0) DG*5.3*109^2 "BLD",5386,"REQB",2,0) DG*5.3*560^2 "BLD",5386,"REQB",3,0) DG*5.3*586^2 "BLD",5386,"REQB","B","DG*5.3*109",1) "BLD",5386,"REQB","B","DG*5.3*560",2) "BLD",5386,"REQB","B","DG*5.3*586",3) "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) 581^3040512^100850 "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") 3 "RTN","DGPREBJ") 0^2^B12768948 "RTN","DGPREBJ",1,0) DGPREBJ ;Boise/WRL/ALB/SCK-PreRegistration Night Task Job ; 3/22/04 11:51am "RTN","DGPREBJ",2,0) ;;5.3;Registration;**109,581**;Aug 13, 1993 "RTN","DGPREBJ",3,0) Q "RTN","DGPREBJ",4,0) ; "RTN","DGPREBJ",5,0) EN ; Main entry point for the Pre-Registration Background Job. "RTN","DGPREBJ",6,0) ; Variables "RTN","DGPREBJ",7,0) ; DGPTOD - Current date "RTN","DGPREBJ",8,0) ; DGPNL - Message line count for mail message "RTN","DGPREBJ",9,0) ; DGPFNC - Job function "RTN","DGPREBJ",10,0) ; DGPNDAY - Number of days to keep entries in the call list "RTN","DGPREBJ",11,0) ; DGPTXT - Message array "RTN","DGPREBJ",12,0) ; DGPDT - Last date to keep entries in call list for, uses DGPNDAY "RTN","DGPREBJ",13,0) ; DGPN1-2 - Temporary Var's for $ORDER "RTN","DGPREBJ",14,0) ; DGPCLD - Count of call log entries purged "RTN","DGPREBJ",15,0) ; "RTN","DGPREBJ",16,0) N DGPTXT,DGPTOD,DGPFNC,DGPNL,DGPCLD,DGPDT,DGPN1,DGPN2,DGPNDAY "RTN","DGPREBJ",17,0) ; "RTN","DGPREBJ",18,0) S DGPTOD=$$DT^XLFDT() "RTN","DGPREBJ",19,0) ; "RTN","DGPREBJ",20,0) S DGPNL=1 "RTN","DGPREBJ",21,0) ; "RTN","DGPREBJ",22,0) S DGPFNC=$P($G(^DG(43,1,"DGPRE")),U,3) "RTN","DGPREBJ",23,0) I DGPFNC']""!(DGPFNC="N") D MES("MES1") G EXIT "RTN","DGPREBJ",24,0) ; "RTN","DGPREBJ",25,0) ; DG/581 - delete certain entries in DGS(41.42 "RTN","DGPREBJ",26,0) N DGTDAY,DGIEN,DGOLD,DGZERO,DGDFN,DGAPDT,DGKFLAG "RTN","DGPREBJ",27,0) D NOW^%DTC S DGTDAY=% "RTN","DGPREBJ",28,0) S (DGIEN,DGOLD)=0 "RTN","DGPREBJ",29,0) F S DGIEN=$O(^DGS(41.42,DGIEN)) Q:'DGIEN D "RTN","DGPREBJ",30,0) .S DGZERO=$G(^DGS(41.42,DGIEN,0)) Q:DGZERO="" "RTN","DGPREBJ",31,0) .S DGDFN=$P(DGZERO,U),DGAPDT=$P(DGZERO,U,8) "RTN","DGPREBJ",32,0) .Q:('DGDFN)!('DGAPDT) "RTN","DGPREBJ",33,0) .S DGKFLAG=0 "RTN","DGPREBJ",34,0) .; delete if appt date less than NOW "RTN","DGPREBJ",35,0) .I DGAPDTDGPDT) D "RTN","DGPREBJ",57,0) . S DGPN2=0 F S DGPN2=$O(^DGS(41.43,"B",DGPN1,DGPN2)) Q:'DGPN2 D "RTN","DGPREBJ",58,0) .. S DGPCLD=DGPCLD+1 "RTN","DGPREBJ",59,0) .. S DIK="^DGS(41.43," "RTN","DGPREBJ",60,0) .. S DA=DGPN2 "RTN","DGPREBJ",61,0) .. D ^DIK K DIC "RTN","DGPREBJ",62,0) ; "RTN","DGPREBJ",63,0) D SETTEXT("Number of Entries Deleted From Call History: "_DGPCLD) "RTN","DGPREBJ",64,0) D SETTEXT(" ") "RTN","DGPREBJ",65,0) ; "RTN","DGPREBJ",66,0) EXIT ; "RTN","DGPREBJ",67,0) D SEND "RTN","DGPREBJ",68,0) Q "RTN","DGPREBJ",69,0) ; "RTN","DGPREBJ",70,0) SEND ; Send notification of actions taken to mailgroup "RTN","DGPREBJ",71,0) S XMY("G.DGPRE PRE-REG STAFF")="" "RTN","DGPREBJ",72,0) S XMDUZ=$S($G(DUZ)>0:DUZ,1:.5) "RTN","DGPREBJ",73,0) S XMTEXT="DGPTXT(" "RTN","DGPREBJ",74,0) S XMSUB="PRE-REGISTRATION NIGHTLY JOB REPORT" "RTN","DGPREBJ",75,0) D XMZ^XMA2 "RTN","DGPREBJ",76,0) D:XMZ>0 ^XMD "RTN","DGPREBJ",77,0) K XMY,XMDUZ,XMTEXT,XMSUB "RTN","DGPREBJ",78,0) Q "RTN","DGPREBJ",79,0) ; "RTN","DGPREBJ",80,0) SETTEXT(DGLINE) ; Add text line to message array "RTN","DGPREBJ",81,0) S DGPTXT(DGPNL)=DGLINE "RTN","DGPREBJ",82,0) S DGPNL=DGPNL+1 "RTN","DGPREBJ",83,0) Q "RTN","DGPREBJ",84,0) ; "RTN","DGPREBJ",85,0) PURGECP ; Purge called patients from the Pre-registration call list "RTN","DGPREBJ",86,0) ; Variables "RTN","DGPREBJ",87,0) ; DGPDEL - Counter of records deleted "RTN","DGPREBJ",88,0) ; "RTN","DGPREBJ",89,0) N DGPDEL "RTN","DGPREBJ",90,0) S DGPDEL=0 "RTN","DGPREBJ",91,0) ; "RTN","DGPREBJ",92,0) D PRGLST^DGPREP4(0,.DGPDEL) "RTN","DGPREBJ",93,0) ; "RTN","DGPREBJ",94,0) D SETTEXT(DGPDEL_" Called Patients Purged.") "RTN","DGPREBJ",95,0) D SETTEXT(" ") "RTN","DGPREBJ",96,0) Q "RTN","DGPREBJ",97,0) ; "RTN","DGPREBJ",98,0) KILLALL ; Clear all entries from the pre-registration call list. "RTN","DGPREBJ",99,0) ; Variables "RTN","DGPREBJ",100,0) ; DGPTOT - Counter if entries deleted "RTN","DGPREBJ",101,0) ; "RTN","DGPREBJ",102,0) N DGPTOT "RTN","DGPREBJ",103,0) S DGPTOT=0 "RTN","DGPREBJ",104,0) ; "RTN","DGPREBJ",105,0) D CLRLST^DGPREP4(0,.DGPTOT) "RTN","DGPREBJ",106,0) ; "RTN","DGPREBJ",107,0) D SETTEXT(DGPTOT_" Entries Deleted from the Call List.") "RTN","DGPREBJ",108,0) D SETTEXT(" ") "RTN","DGPREBJ",109,0) Q "RTN","DGPREBJ",110,0) ; "RTN","DGPREBJ",111,0) MES(TAG) ; Build message for missing parameters "RTN","DGPREBJ",112,0) N DGMES,I "RTN","DGPREBJ",113,0) ; "RTN","DGPREBJ",114,0) F I=1:1 S DGMES=$P($T(@TAG+I),";;",2,99) Q:DGMES="$$END" D SETTEXT(DGMES) "RTN","DGPREBJ",115,0) D SETTEXT(" ") "RTN","DGPREBJ",116,0) Q "RTN","DGPREBJ",117,0) ; "RTN","DGPREBJ",118,0) MES1 ; "RTN","DGPREBJ",119,0) ;;There is either no entry or a 'No Action' entry in the 'CALL LIST NIGHT JOB "RTN","DGPREBJ",120,0) ;;FUNCTION' field in the site parameter file. No action will be taken on the "RTN","DGPREBJ",121,0) ;;Call List. "RTN","DGPREBJ",122,0) ;;$$END "RTN","DGPREP0") 0^1^B25300465 "RTN","DGPREP0",1,0) DGPREP0 ;Boise/WRL/ALB/SCK-Program to Display Pre-Registration List ; 2/24/04 2:11pm "RTN","DGPREP0",2,0) ;;5.3;Registration;**109,546,586,581**;Aug 13, 1993 "RTN","DGPREP0",3,0) Q "RTN","DGPREP0",4,0) ; "RTN","DGPREP0",5,0) EN ; -- main entry point "RTN","DGPREP0",6,0) N VAUTD,X1 "RTN","DGPREP0",7,0) ; "RTN","DGPREP0",8,0) I '$D(^XUSEC("DGPRE EDIT",DUZ))&('$D(^XUSEC("DGPRE SUPV",DUZ))) D G ENQ "RTN","DGPREP0",9,0) . W !!,"You do not have the requisite key allocated, contact your Supervisor." "RTN","DGPREP0",10,0) ; *** Select Divisions "RTN","DGPREP0",11,0) I $P($G(^DG(43,1,"GL")),U,2) D "RTN","DGPREP0",12,0) . D DIVISION^VAUTOMA "RTN","DGPREP0",13,0) E D "RTN","DGPREP0",14,0) . S DGSNGLDV=1 "RTN","DGPREP0",15,0) . S VAUTD=1 "RTN","DGPREP0",16,0) ; "RTN","DGPREP0",17,0) D EN^VALM("DGPRE RG") "RTN","DGPREP0",18,0) ENQ Q "RTN","DGPREP0",19,0) ; "RTN","DGPREP0",20,0) HDR ; -- header code "RTN","DGPREP0",21,0) ; Variables "RTN","DGPREP0",22,0) ; DGPSRT - Sort Method for call list display "RTN","DGPREP0",23,0) ; "RTN","DGPREP0",24,0) N DGPSRT "RTN","DGPREP0",25,0) I $D(VAUTD) S VALMHDR(1)="Call List sorted by Division and then " "RTN","DGPREP0",26,0) S DGPSRT=$P($G(^DG(43,1,"DGPRE")),U) "RTN","DGPREP0",27,0) S VALMHDR(1)=$G(VALMHDR(1))_"Sorted by "_$S(DGPSRT="P":"Patient Name",DGPSRT="S":"Medical Service")_"." "RTN","DGPREP0",28,0) I $G(VAUTD) S VALMHDR(2)="All Divisions selected." "RTN","DGPREP0",29,0) Q "RTN","DGPREP0",30,0) ; "RTN","DGPREP0",31,0) INIT ; -- Retrieve data from call list and build TMP global for sorting Call lsit "RTN","DGPREP0",32,0) ; Variables "RTN","DGPREP0",33,0) ; DGPNR - "RTN","DGPREP0",34,0) ; DGPDATA - 0 Node from ^DGS(41.42,X "RTN","DGPREP0",35,0) ; DGPDATA1 - 1 Node from ^DGS(41.42,X "RTN","DGPREP0",36,0) ; DGPDIV - Division IEN from ^DGS(41.42, "RTN","DGPREP0",37,0) ; DGPDVN - Division Name "RTN","DGPREP0",38,0) ; DGPSV - Medical Service for appointment clinic "RTN","DGPREP0",39,0) ; DGPAT - Appt. date/time "RTN","DGPREP0",40,0) ; DGPPN - Patients name "RTN","DGPREP0",41,0) ; DGPNR - Index No. for LM "RTN","DGPREP0",42,0) ; DGPSRT - Call list sort method "RTN","DGPREP0",43,0) ; DGPN0,DGPN1,DGPNX - Local Var's for $O "RTN","DGPREP0",44,0) ; "RTN","DGPREP0",45,0) N DGQ,DGPDATA,DGPDATA1,DGPDIV,DGPDVN,DGPNX,DGPN1,DGPN2 "RTN","DGPREP0",46,0) ; "RTN","DGPREP0",47,0) K ^TMP("DGPRERG",$J) "RTN","DGPREP0",48,0) K ^TMP($J) "RTN","DGPREP0",49,0) S DGPSRT=$P($G(^DG(43,1,"DGPRE")),U) "RTN","DGPREP0",50,0) I $P($G(^DGS(41.42,0)),U,4)>1 W !!,"Sorting Entries..." "RTN","DGPREP0",51,0) ; "RTN","DGPREP0",52,0) S DGPN1=0 F S DGPN1=$O(^DGS(41.42,DGPN1)) Q:'DGPN1 D "RTN","DGPREP0",53,0) . S DGPDATA=$G(^DGS(41.42,DGPN1,0)),DGPDATA1=$G(^DGS(41.42,DGPN1,1)) "RTN","DGPREP0",54,0) . Q:DGPDATA']""!(DGPDATA1']"") "RTN","DGPREP0",55,0) . ; **** Division handling "RTN","DGPREP0",56,0) . S DGPDIV=$P(DGPDATA,U,2) "RTN","DGPREP0",57,0) . I +DGPDIV'>0 D "RTN","DGPREP0",58,0) .. I $G(DGSNGLDV) S DGPDIV=$S($D(^DG(40.8,1)):1,1:0) Q "RTN","DGPREP0",59,0) .. S DGPDIV=-1 "RTN","DGPREP0",60,0) . K DGQ "RTN","DGPREP0",61,0) . I '$G(DGSNGLDV) D Q:$G(DGQ) "RTN","DGPREP0",62,0) .. I '$G(VAUTD),'$D(VAUTD(DGPDIV)) S DGQ=1 "RTN","DGPREP0",63,0) . ; "RTN","DGPREP0",64,0) . S DGPSV=$P(DGPDATA1,U) "RTN","DGPREP0",65,0) . S DGPAT=$P(DGPDATA,U,8) "RTN","DGPREP0",66,0) . S DGPPN=$P(^DPT($P(^DGS(41.42,DGPN1,0),U),0),U) "RTN","DGPREP0",67,0) . ; "RTN","DGPREP0",68,0) . I DGPSRT="S" D "RTN","DGPREP0",69,0) .. I DGPSV']"" W !,"NO SERVICE ENTRY FOR RECORD# ",DGPN1 Q "RTN","DGPREP0",70,0) .. S ^TMP($J,DGPDIV,DGPSV,DGPN1)=$P(^DGS(41.42,DGPN1,0),U) "RTN","DGPREP0",71,0) . ; "RTN","DGPREP0",72,0) . I DGPSRT="P" D "RTN","DGPREP0",73,0) .. I DGPPN']"" W !,"NO PATIENT ENTRY FOR RECORD# ",DGPN1 Q "RTN","DGPREP0",74,0) .. S ^TMP($J,DGPDIV,DGPPN,DGPN1)=$P($G(^DGS(41.42,DGPN1,0)),U) "RTN","DGPREP0",75,0) . ; "RTN","DGPREP0",76,0) . I DGPSRT']"" D "RTN","DGPREP0",77,0) .. I DGPPN']"" W !,"NO PATIENT ENTRY FOR RECORD# ",DGPN1 Q "RTN","DGPREP0",78,0) .. S ^TMP($J,DGPDIV,DGPPN,DGPN1)=$P(^DGS(41.42,DGPN1,0),U) "RTN","DGPREP0",79,0) . W "." "RTN","DGPREP0",80,0) ; "RTN","DGPREP0",81,0) I $D(^TMP($J)) W !!,"Loading Sorted Entries into List..." "RTN","DGPREP0",82,0) E D "RTN","DGPREP0",83,0) . W *7,!!,"No appointments were found for the selected divisions" "RTN","DGPREP0",84,0) . K DIR S DIR(0)="E" D ^DIR K DIR "RTN","DGPREP0",85,0) ; "RTN","DGPREP0",86,0) ; Retreive sorted call list form ^TMP and build LM arrays "RTN","DGPREP0",87,0) ; "RTN","DGPREP0",88,0) S DGPNR=1 "RTN","DGPREP0",89,0) S DGPN0="" F S DGPN0=$O(^TMP($J,DGPN0)) Q:DGPN0="" D "RTN","DGPREP0",90,0) . S DGPN1="" F S DGPN1=$O(^TMP($J,DGPN0,DGPN1)) Q:DGPN1="" D "RTN","DGPREP0",91,0) .. S DGPNX="" F S DGPNX=$O(^TMP($J,DGPN0,DGPN1,DGPNX)) Q:DGPNX="" D "RTN","DGPREP0",92,0) ... S DGPDATA=$G(^DGS(41.42,DGPNX,0)) "RTN","DGPREP0",93,0) ... S DGPDATA1=$G(^DGS(41.42,DGPNX,1)) "RTN","DGPREP0",94,0) ... S DGPSV=$P(DGPDATA1,U) "RTN","DGPREP0",95,0) ... S X=$$SETFLD^VALM1(DGPNR,"","INDEX") "RTN","DGPREP0",96,0) ... S X=$$SETFLD^VALM1($E($P(^DPT($P(DGPDATA,U),0),U),1,30),X,"PATIENT") "RTN","DGPREP0",97,0) ... S DGPDFN=$P(DGPDATA,U) "RTN","DGPREP0",98,0) ... D BLDHIST "RTN","DGPREP0",99,0) ... S X=$$SETFLD^VALM1($P(DGPDATA1,U,2),X,"SSN") "RTN","DGPREP0",100,0) ... S X=$$SETFLD^VALM1(DGPSV,X,"SVC") "RTN","DGPREP0",101,0) ... S X=$$SETFLD^VALM1($E($P(DGPDATA1,U,3),1,18),X,"PHONE") "RTN","DGPREP0",102,0) ... S X=$$SETFLD^VALM1($$FMTE^XLFDT($P(DGPDATA,U,5),"2D"),X,"LAST") "RTN","DGPREP0",103,0) ... I $P(DGPDATA,U,6)="Y" D "RTN","DGPREP0",104,0) .... ;S X=$$SETFLD^VALM1("*",X,"CALL") "RTN","DGPREP0",105,0) ... S DGPDVN=$S(+$G(DGPN0)>0:$P(^DG(40.8,DGPN0,0),U),DGPN0<0:"",1:DGPN0) "RTN","DGPREP0",106,0) ... S X=$$SETFLD^VALM1($E(DGPDVN,1,20),X,"DIVISION") "RTN","DGPREP0",107,0) ... S ^TMP("DGPRERG",$J,DGPNR,0)=X "RTN","DGPREP0",108,0) ... S ^TMP("DGPRERG",$J,"DA",DGPNR,DGPN1)="" "RTN","DGPREP0",109,0) ... S ^TMP("DGPRERG",$J,"DFN",DGPNR,DGPDFN)="" "RTN","DGPREP0",110,0) ... S ^TMP("DGPRERG",$J,"SSN",DGPNR,$P(DGPDATA1,U,2))="" "RTN","DGPREP0",111,0) ... S ^TMP("DGPRERG",$J,"IDX",DGPNR,DGPNR)="" "RTN","DGPREP0",112,0) ... S ^TMP("DGPRERG",$J,"DIV",DGPNR,DGPN0)="" "RTN","DGPREP0",113,0) ... S DGPNR=DGPNR+1 "RTN","DGPREP0",114,0) ... W "." "RTN","DGPREP0",115,0) S VALMCNT=DGPNR-1 "RTN","DGPREP0",116,0) I VALMCNT'>0 S VALMQUIT=1 "RTN","DGPREP0",117,0) Q "RTN","DGPREP0",118,0) ; "RTN","DGPREP0",119,0) HELP ; -- help code "RTN","DGPREP0",120,0) S X="?" D DISP^XQORM1 W !! "RTN","DGPREP0",121,0) Q "RTN","DGPREP0",122,0) ; "RTN","DGPREP0",123,0) EXIT ; -- Exit code "RTN","DGPREP0",124,0) K ^TMP("DGPRERG",$J) "RTN","DGPREP0",125,0) K DGPAT,DGPCH,DGPCL,DGPDA,DGPDATA,DGPDATA1,DGPDFN,DGPEDIT,DGPENT,DGPFLG,DGPIFN "RTN","DGPREP0",126,0) K DGPLOC,DGPN0,DGPN1,DGPN2,DGPN3,DGPNR,DGPP1,DGPP2,DGPP3,DGPPN "RTN","DGPREP0",127,0) K DGPPSRT,DGPST,DGPSV,DGPTAT,DA,X,Y,DIR,DIC,DIE "RTN","DGPREP0",128,0) D FULL^VALM1 "RTN","DGPREP0",129,0) D CLEAN^VALM10 "RTN","DGPREP0",130,0) Q "RTN","DGPREP0",131,0) ; "RTN","DGPREP0",132,0) BLDHIST ; Build history of call attempts from ^DGS(41.43, Call log "RTN","DGPREP0",133,0) N DGPN2,DGPN3 "RTN","DGPREP0",134,0) ; "RTN","DGPREP0",135,0) S DGPN2=0 F S DGPN2=$O(^DGS(41.43,"C",DGPDFN,DGPN2)) Q:'DGPN2 D "RTN","DGPREP0",136,0) . S:$P(^DGS(41.43,DGPN2,0),U,4)]"" ^TMP("STAT",$J,$P(^DGS(41.43,DGPN2,0),U,1))=$P(^DGS(41.43,DGPN2,0),U,4) "RTN","DGPREP0",137,0) I $D(^TMP("STAT",$J)) D "RTN","DGPREP0",138,0) . S DGPTAT="" "RTN","DGPREP0",139,0) . S DGPN3=9999999.999999 F S DGPN3=$O(^TMP("STAT",$J,DGPN3),-1) Q:'DGPN3 D "RTN","DGPREP0",140,0) .. S DGPTAT=DGPTAT_^TMP("STAT",$J,DGPN3) "RTN","DGPREP0",141,0) . S X=$$SETFLD^VALM1(DGPTAT,X,"HIST") "RTN","DGPREP0",142,0) . K ^TMP("STAT",$J) "RTN","DGPREP0",143,0) Q "RTN","DGREGAZL") 0^3^B37170348 "RTN","DGREGAZL",1,0) DGREGAZL ;ALB/DW - ZIP LINKING UTILITY ; 3/3/04 1:43pm "RTN","DGREGAZL",2,0) ;;5.3;Registration;**522,560,581**;Aug 13, 1993 "RTN","DGREGAZL",3,0) ; "RTN","DGREGAZL",4,0) EN(RESULT,DFN) ;Let user edit zip+4, city, state, county based on zip-linking "RTN","DGREGAZL",5,0) ; Output: RESULT(field#) = User Input External ^ Internal "RTN","DGREGAZL",6,0) K RESULT "RTN","DGREGAZL",7,0) N DGIND,DGTOT "RTN","DGREGAZL",8,0) I $G(DFN)="" S RESULT=-1 Q "RTN","DGREGAZL",9,0) N DGR,DGDFLT,DGALW,DGZIP,DGN "RTN","DGREGAZL",10,0) S DGN="" "RTN","DGREGAZL",11,0) I $$FOREIGN() D Q "RTN","DGREGAZL",12,0) . D FRGNEDT(.DGR,DFN) "RTN","DGREGAZL",13,0) . I $G(DGR)=-1 S RESULT=-1 Q "RTN","DGREGAZL",14,0) . F DGN=.1112,.114,.115,.117 S RESULT(DGN)=$G(DGR(DGN)) "RTN","DGREGAZL",15,0) S DGZIP=$$ZIP(DFN) "RTN","DGREGAZL",16,0) I DGZIP=-1 S RESULT=-1 Q "RTN","DGREGAZL",17,0) S RESULT(.1112)=DGZIP "RTN","DGREGAZL",18,0) S DGIND=$$CITY(.DGR,DGZIP,DFN) "RTN","DGREGAZL",19,0) I DGIND=$G(DGTOT)+1 S DGIND="" "RTN","DGREGAZL",20,0) I $G(DGR)=-1 S RESULT=-1 Q "RTN","DGREGAZL",21,0) S RESULT(.114)=$G(DGR) "RTN","DGREGAZL",22,0) S DGALW=$$ALWEDT^DGREGDD1($G(DUZ),DGZIP) "RTN","DGREGAZL",23,0) I DGALW=1 D "RTN","DGREGAZL",24,0) . K DGR D STCNTY(.DGR,DGZIP,DFN,DGIND) "RTN","DGREGAZL",25,0) . I $G(DGR)=-1 S RESULT=-1 Q "RTN","DGREGAZL",26,0) . S RESULT(.115)=$G(DGR(.115)) "RTN","DGREGAZL",27,0) . S RESULT(.117)=$G(DGR(.117)) "RTN","DGREGAZL",28,0) I DGALW=0 D "RTN","DGREGAZL",29,0) . I DGZIP'="" D LINK(.DGDFLT,DGZIP,1) "RTN","DGREGAZL",30,0) . S RESULT(.115)=$G(DGDFLT(.115)) "RTN","DGREGAZL",31,0) . S RESULT(.117)=$G(DGDFLT(.117)) "RTN","DGREGAZL",32,0) Q "RTN","DGREGAZL",33,0) ZIP(DFN) ;Let user input zip+4 "RTN","DGREGAZL",34,0) ZAGN N DIR,DTOUT,DUOUT,DIROUT,DGDATA "RTN","DGREGAZL",35,0) S DIR(0)="2,.1112" "RTN","DGREGAZL",36,0) S DA=DFN "RTN","DGREGAZL",37,0) D ^DIR "RTN","DGREGAZL",38,0) I $D(DTOUT) Q -1 "RTN","DGREGAZL",39,0) I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G ZAGN "RTN","DGREGAZL",40,0) S DGZIP=$G(Y) "RTN","DGREGAZL",41,0) ;allow bogus zip: "RTN","DGREGAZL",42,0) I $D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) Q DGZIP "RTN","DGREGAZL",43,0) I DGZIP="" Q DGZIP "RTN","DGREGAZL",44,0) D POSTALB^XIPUTIL(DGZIP,.DGDATA) "RTN","DGREGAZL",45,0) I $D(DGDATA("ERROR")) D G ZAGN "RTN","DGREGAZL",46,0) . W $C(7)," ??" "RTN","DGREGAZL",47,0) Q DGZIP "RTN","DGREGAZL",48,0) CITY(RESULT,ZIP,DFN) ;Base on zip, let user input city(#.114) "RTN","DGREGAZL",49,0) ; Input: "RTN","DGREGAZL",50,0) ; ZIP - user input zip for the patient primary address "RTN","DGREGAZL",51,0) ; DFN - Interal entry number of Patient File (#2) "RTN","DGREGAZL",52,0) ; Output:RESULT=-1 (input error or times or ^ out) "RTN","DGREGAZL",53,0) ; or =user input city "RTN","DGREGAZL",54,0) ; Array index # of selected city. "RTN","DGREGAZL",55,0) K RESULT "RTN","DGREGAZL",56,0) N DGDATA,DIR,DA,Y,DTOUT,DUOUT,DIROUT,DGIND "RTN","DGREGAZL",57,0) N DGCITY,DGST,DGCNTY,DGABRV,DGN,DGECH,DGSOC "RTN","DGREGAZL",58,0) N DOLDCITY,DGSAME,DGELEVEN "RTN","DGREGAZL",59,0) S DGIND="" "RTN","DGREGAZL",60,0) D POSTALB^XIPUTIL(ZIP,.DGDATA) "RTN","DGREGAZL",61,0) D FIELD^DID(2,.114,"N","LABEL","DGCITY") "RTN","DGREGAZL",62,0) S DGN="" "RTN","DGREGAZL",63,0) I '$D(DGDATA("ERROR")) D "RTN","DGREGAZL",64,0) . S DOLDCITY=$$GET1^DIQ(2,DFN_",",.114) "RTN","DGREGAZL",65,0) . S DGSAME=0 "RTN","DGREGAZL",66,0) . F S DGN=$O(DGDATA(DGN)) Q:DGN="" D "RTN","DGREGAZL",67,0) .. S DGABRV=$G(DGDATA(DGN,"CITY ABBREVIATION")) "RTN","DGREGAZL",68,0) .. I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1 "RTN","DGREGAZL",69,0) .. I DGABRV="" S DGABRV=$P($G(DGDATA(DGN,"CITY")),"*",1) "RTN","DGREGAZL",70,0) .. I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1 "RTN","DGREGAZL",71,0) .. I $G(DGDATA(DGN,"CITY"))["*" S:DGABRV'="" DGABRV=DGABRV_"*" "RTN","DGREGAZL",72,0) .. S DGECH=DGN_":"_DGABRV "RTN","DGREGAZL",73,0) .. S DGSOC=$S($G(DGSOC)="":DGECH,1:DGSOC_";"_DGECH) "RTN","DGREGAZL",74,0) .. S DGTOT=DGN "RTN","DGREGAZL",75,0) .I 'DGSAME S DGELEVEN=$G(^DPT(DFN,.11)) D "RTN","DGREGAZL",76,0) ..Q:$P(DGELEVEN,U,6)'=$G(DGDATA(DGTOT,"POSTAL CODE")) "RTN","DGREGAZL",77,0) ..Q:$P(DGELEVEN,U,14)'="VAMC" "RTN","DGREGAZL",78,0) ..Q:$P(DGELEVEN,U,15)'=$$GETSITE^DGMTU4($G(DUZ)) "RTN","DGREGAZL",79,0) ..Q:$P(DGELEVEN,U,17)'>.5 "RTN","DGREGAZL",80,0) ..S DGN=DGTOT+1,DGECH=DGN_":"_DOLDCITY,DGSOC=DGSOC_";"_DGECH "RTN","DGREGAZL",81,0) .; "RTN","DGREGAZL",82,0) . I $D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) D "RTN","DGREGAZL",83,0) .. S DGSOC=$G(DGSOC)_";"_99_":"_"FREE TEXT" "RTN","DGREGAZL",84,0) . S DIR(0)="SO^"_$G(DGSOC) "RTN","DGREGAZL",85,0) . ;if zip '= zip on file, default = ""; else default=city on file "RTN","DGREGAZL",86,0) . ;I ($G(DFN)'="")&($E(ZIP,1,5)=$$GET1^DIQ(2,DFN_",",.116)) D "RTN","DGREGAZL",87,0) . S DIR("B")=$$GET1^DIQ(2,DFN_",",.114) "RTN","DGREGAZL",88,0) . S DIR("A")=$G(DGCITY("LABEL")) "RTN","DGREGAZL",89,0) CAGN1 . D ^DIR "RTN","DGREGAZL",90,0) . I $D(DTOUT) S RESULT=-1 Q "RTN","DGREGAZL",91,0) . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G CAGN1 "RTN","DGREGAZL",92,0) . S RESULT=$P($G(Y(0)),"*") "RTN","DGREGAZL",93,0) . S DGIND=$G(Y) "RTN","DGREGAZL",94,0) I ($G(Y)=99)!($D(DGDATA("ERROR"))) D "RTN","DGREGAZL",95,0) CAGN2 . I '$D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) Q "RTN","DGREGAZL",96,0) . N DIR,X,Y "RTN","DGREGAZL",97,0) . S DIR(0)="2,.114" "RTN","DGREGAZL",98,0) . S DA=DFN "RTN","DGREGAZL",99,0) . D ^DIR "RTN","DGREGAZL",100,0) . I $D(DTOUT) S RESULT=-1 Q "RTN","DGREGAZL",101,0) . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G CAGN2 "RTN","DGREGAZL",102,0) . S RESULT=$G(Y) "RTN","DGREGAZL",103,0) I $L($G(RESULT))>15 S RESULT=$E(RESULT,1,15) "RTN","DGREGAZL",104,0) Q DGIND "RTN","DGREGAZL",105,0) ; "RTN","DGREGAZL",106,0) LINK(RESULT,ZIP,DGN) ;From zip, get the linked state,county "RTN","DGREGAZL",107,0) K RESULT "RTN","DGREGAZL",108,0) N DGDATA,CNTYIEN "RTN","DGREGAZL",109,0) S CNTYIEN="" "RTN","DGREGAZL",110,0) S DGN=$G(DGN) "RTN","DGREGAZL",111,0) I (DGN="")&($$MLT^DGREGDD1(ZIP)) S DGN=1 "RTN","DGREGAZL",112,0) I (DGN=99)&($$MLT^DGREGDD1(ZIP)) S DGN=1 "RTN","DGREGAZL",113,0) I (DGN="")!(DGN=99) Q "RTN","DGREGAZL",114,0) D POSTALB^XIPUTIL(ZIP,.DGDATA) "RTN","DGREGAZL",115,0) S:$G(DGDATA(DGN,"STATE POINTER"))'="" CNTYIEN=$$FIND1^DIC(5.01,","_$G(DGDATA(DGN,"STATE POINTER"))_",","MOXQ",$E($G(DGDATA(DGN,"FIPS CODE")),3,5),"C") "RTN","DGREGAZL",116,0) D:'CNTYIEN ;could be duplicate county codes in subfile #5.01 "RTN","DGREGAZL",117,0) .Q:'$D(^DIC(5,+$G(DGDATA(DGN,"STATE POINTER")),1)) "RTN","DGREGAZL",118,0) .Q:$E($G(DGDATA(DGN,"FIPS CODE")),3,5)="" "RTN","DGREGAZL",119,0) .S CNTYIEN=$O(^DIC(5,$G(DGDATA(DGN,"STATE POINTER")),1,"C",$E($G(DGDATA(DGN,"FIPS CODE")),3,5),"")) "RTN","DGREGAZL",120,0) S RESULT(.115)=$G(DGDATA(DGN,"STATE"))_U_$G(DGDATA(DGN,"STATE POINTER")) "RTN","DGREGAZL",121,0) S RESULT(.117)=$G(DGDATA(DGN,"COUNTY"))_U_$G(CNTYIEN)_U_$E($G(DGDATA(DGN,"FIPS CODE")),3,5) "RTN","DGREGAZL",122,0) Q "RTN","DGREGAZL",123,0) ; "RTN","DGREGAZL",124,0) STCNTY(RESULT,ZIP,DFN,DGNUM) ;Based on zip,input state (#.115) and county (#.117) "RTN","DGREGAZL",125,0) K RESULT "RTN","DGREGAZL",126,0) S DGNUM=$G(DGNUM) "RTN","DGREGAZL",127,0) N DGN,DGDFLT,DGST,POP,DIR,X,Y,DTOUT,DUOUT,DIROUT "RTN","DGREGAZL",128,0) S POP=0 "RTN","DGREGAZL",129,0) D LINK(.DGDFLT,ZIP,DGNUM) "RTN","DGREGAZL",130,0) F DGN=.115,.117 Q:POP D "RTN","DGREGAZL",131,0) SCAGN . I DGN=.115 S DIR(0)=2_","_DGN "RTN","DGREGAZL",132,0) . I ($G(DGST)="")&(DGN=.117) Q "RTN","DGREGAZL",133,0) . I DGN=.117 S DIR(0)="POA^DIC(5,DGST,1,:AEMQ" "RTN","DGREGAZL",134,0) . S DIR("B")=$P($G(DGDFLT(DGN)),U) "RTN","DGREGAZL",135,0) . D ^DIR "RTN","DGREGAZL",136,0) . I $D(DTOUT) S POP=1 Q "RTN","DGREGAZL",137,0) . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G SCAGN "RTN","DGREGAZL",138,0) . S RESULT(DGN)=$P($G(Y),U,2)_U_$P($G(Y),U) "RTN","DGREGAZL",139,0) . I DGN=.115 S DGST=$P($G(Y),U) "RTN","DGREGAZL",140,0) . I DGN=.117 S RESULT(.117)=$$CNTY(DGST,$P($G(RESULT(.117)),U,2)) "RTN","DGREGAZL",141,0) I POP=1 S RESULT=-1 "RTN","DGREGAZL",142,0) Q "RTN","DGREGAZL",143,0) CNTY(DGST,DGCIEN) ;Return county name and code "RTN","DGREGAZL",144,0) ;Input:state number and county IEN "RTN","DGREGAZL",145,0) ;Output: CountyName^CountyIEN^CountyCode "RTN","DGREGAZL",146,0) I ($G(DGST)="")!($G(DGCIEN)="") S RESULT=-1 Q RESULT "RTN","DGREGAZL",147,0) N DGR,RESULT "RTN","DGREGAZL",148,0) S DGR=$G(^DIC(5,DGST,1,DGCIEN,0)) "RTN","DGREGAZL",149,0) S RESULT=$P($G(DGR),U)_U_DGCIEN_U_$P($G(DGR),U,3) "RTN","DGREGAZL",150,0) Q RESULT "RTN","DGREGAZL",151,0) FOREIGN() ;Manila (Philippines) doesn't need zip linking. "RTN","DGREGAZL",152,0) ;Output: 1 - area need no zip linking "RTN","DGREGAZL",153,0) ; 0 - zip-linking area "RTN","DGREGAZL",154,0) I $$STA^XUAF4(+$$KSP^XUPARAM("INST"))=358 Q 1 "RTN","DGREGAZL",155,0) ;;;I $$STA^XUAF4(+$$KSP^XUPARAM("INST"))=500 Q 1 ;;HERE TEST "RTN","DGREGAZL",156,0) Q 0 "RTN","DGREGAZL",157,0) FRGNEDT(DGINPUT,DFN) ;Edit zip+4, city, state, county for no zip-linking area "RTN","DGREGAZL",158,0) K DGINPUT "RTN","DGREGAZL",159,0) N DGN,DIR,DTOUT,DUOUT,DIROUT,X,Y,POP,DGST "RTN","DGREGAZL",160,0) S POP=0 "RTN","DGREGAZL",161,0) F DGN=.1112,.114,.115,.117 Q:POP D "RTN","DGREGAZL",162,0) FAGN . I ($G(DGST)="")&(DGN=.117) Q "RTN","DGREGAZL",163,0) . S DIR(0)=2_","_DGN "RTN","DGREGAZL",164,0) . I DGN=.117 D "RTN","DGREGAZL",165,0) .. S DIR(0)="POA^DIC(5,DGST,1,:AEMQ" "RTN","DGREGAZL",166,0) .. S DIR("B")=$$GET1^DIQ(2,DFN_",",.117) "RTN","DGREGAZL",167,0) . I DGN'=.117 S DA=DFN "RTN","DGREGAZL",168,0) . D ^DIR "RTN","DGREGAZL",169,0) . I $D(DTOUT) S POP=1 Q "RTN","DGREGAZL",170,0) . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G FAGN "RTN","DGREGAZL",171,0) . I (DGN=.114)!(DGN=.1112) S DGINPUT(DGN)=$G(Y) "RTN","DGREGAZL",172,0) . I (DGN=.115) D "RTN","DGREGAZL",173,0) .. S DGST=$P($G(Y),U) "RTN","DGREGAZL",174,0) .. I DGST=$$GET1^DIQ(2,DFN_",",.115,"I") D "RTN","DGREGAZL",175,0) ... S DGINPUT(.115)=$$GET1^DIQ(2,DFN_",",.115)_U_DGST "RTN","DGREGAZL",176,0) .. I DGST'=$$GET1^DIQ(2,DFN_",",.115,"I") D "RTN","DGREGAZL",177,0) ... S DGINPUT(.115)=$P($G(Y(0)),U)_U_DGST "RTN","DGREGAZL",178,0) . I DGN=.117 S DGINPUT(DGN)=$P($G(Y),U,2)_U_$P($G(Y),U) "RTN","DGREGAZL",179,0) I POP=1 S RESULT=-1 "RTN","DGREGAZL",180,0) Q "VER") 8.0^22 **END** **END**