Released SD*5.3*491 SEQ #437 Extracted from mail message **KIDS**:SD*5.3*491^ **INSTALL NAME** SD*5.3*491 "BLD",6897,0) SD*5.3*491^SCHEDULING^0^3080701^y "BLD",6897,1,0) ^^1^1^3080701^^^ "BLD",6897,1,1,0) This patch addresses several EWL, PAIT, and Scheduling issues. "BLD",6897,4,0) ^9.64PA^409.32^1 "BLD",6897,4,409.32,0) 409.32 "BLD",6897,4,409.32,2,0) ^9.641^409.32^1 "BLD",6897,4,409.32,2,409.32,0) SD WL CLINIC LOCATION (File-top level) "BLD",6897,4,409.32,2,409.32,1,0) ^9.6411^3^3 "BLD",6897,4,409.32,2,409.32,1,.01,0) CLINIC "BLD",6897,4,409.32,2,409.32,1,.02,0) INSTITUTION "BLD",6897,4,409.32,2,409.32,1,3,0) DATE INACTIVATED "BLD",6897,4,409.32,222) y^n^p^^^^n^^n "BLD",6897,4,409.32,224) "BLD",6897,4,"APDD",409.32,409.32) "BLD",6897,4,"APDD",409.32,409.32,.01) "BLD",6897,4,"APDD",409.32,409.32,.02) "BLD",6897,4,"APDD",409.32,409.32,3) "BLD",6897,4,"B",409.32,409.32) "BLD",6897,6) 6^ "BLD",6897,6.3) 53 "BLD",6897,"INIT") POST^SD53P491 "BLD",6897,"KRN",0) ^9.67PA^8989.52^19 "BLD",6897,"KRN",.4,0) .4 "BLD",6897,"KRN",.401,0) .401 "BLD",6897,"KRN",.401,"NM",0) ^9.68A^1^1 "BLD",6897,"KRN",.401,"NM",1,0) SD-PAIT REJECTED APPT FILE #409.6^409.6^0 "BLD",6897,"KRN",.401,"NM","B","SD-PAIT REJECTED APPT FILE #409.6",1) "BLD",6897,"KRN",.402,0) .402 "BLD",6897,"KRN",.403,0) .403 "BLD",6897,"KRN",.5,0) .5 "BLD",6897,"KRN",.84,0) .84 "BLD",6897,"KRN",3.6,0) 3.6 "BLD",6897,"KRN",3.8,0) 3.8 "BLD",6897,"KRN",9.2,0) 9.2 "BLD",6897,"KRN",9.8,0) 9.8 "BLD",6897,"KRN",9.8,"NM",0) ^9.68A^16^15 "BLD",6897,"KRN",9.8,"NM",1,0) SDWLCU5^^0^B43176687 "BLD",6897,"KRN",9.8,"NM",2,0) SCRPW62^^0^B35851518 "BLD",6897,"KRN",9.8,"NM",3,0) SCRPW63^^0^B82534339 "BLD",6897,"KRN",9.8,"NM",4,0) SDAL^^0^B25084907 "BLD",6897,"KRN",9.8,"NM",5,0) SDAM10^^0^B8926237 "BLD",6897,"KRN",9.8,"NM",6,0) SDAMVSC^^0^B8458150 "BLD",6897,"KRN",9.8,"NM",7,0) SDRPA00^^0^B83224590 "BLD",6897,"KRN",9.8,"NM",8,0) SDRPA04^^0^B41493577 "BLD",6897,"KRN",9.8,"NM",9,0) SDRPA05^^0^B24753499 "BLD",6897,"KRN",9.8,"NM",10,0) SDRPA06^^0^B58773674 "BLD",6897,"KRN",9.8,"NM",12,0) SDWLPE^^0^B27362076 "BLD",6897,"KRN",9.8,"NM",13,0) SDWLREB^^0^B72917718 "BLD",6897,"KRN",9.8,"NM",14,0) SDWLCU3^^0^B9829968 "BLD",6897,"KRN",9.8,"NM",15,0) SDWLCU6^^0^B10460494 "BLD",6897,"KRN",9.8,"NM",16,0) SDRPA03^^1^ "BLD",6897,"KRN",9.8,"NM","B","SCRPW62",2) "BLD",6897,"KRN",9.8,"NM","B","SCRPW63",3) "BLD",6897,"KRN",9.8,"NM","B","SDAL",4) "BLD",6897,"KRN",9.8,"NM","B","SDAM10",5) "BLD",6897,"KRN",9.8,"NM","B","SDAMVSC",6) "BLD",6897,"KRN",9.8,"NM","B","SDRPA00",7) "BLD",6897,"KRN",9.8,"NM","B","SDRPA03",16) "BLD",6897,"KRN",9.8,"NM","B","SDRPA04",8) "BLD",6897,"KRN",9.8,"NM","B","SDRPA05",9) "BLD",6897,"KRN",9.8,"NM","B","SDRPA06",10) "BLD",6897,"KRN",9.8,"NM","B","SDWLCU3",14) "BLD",6897,"KRN",9.8,"NM","B","SDWLCU5",1) "BLD",6897,"KRN",9.8,"NM","B","SDWLCU6",15) "BLD",6897,"KRN",9.8,"NM","B","SDWLPE",12) "BLD",6897,"KRN",9.8,"NM","B","SDWLREB",13) "BLD",6897,"KRN",19,0) 19 "BLD",6897,"KRN",19,"NM",0) ^9.68A^^ "BLD",6897,"KRN",19.1,0) 19.1 "BLD",6897,"KRN",19.1,"NM",0) ^9.68A^^ "BLD",6897,"KRN",101,0) 101 "BLD",6897,"KRN",101,"NM",0) ^9.68A^^ "BLD",6897,"KRN",409.61,0) 409.61 "BLD",6897,"KRN",771,0) 771 "BLD",6897,"KRN",870,0) 870 "BLD",6897,"KRN",8989.51,0) 8989.51 "BLD",6897,"KRN",8989.52,0) 8989.52 "BLD",6897,"KRN",8994,0) 8994 "BLD",6897,"KRN","B",.4,.4) "BLD",6897,"KRN","B",.401,.401) "BLD",6897,"KRN","B",.402,.402) "BLD",6897,"KRN","B",.403,.403) "BLD",6897,"KRN","B",.5,.5) "BLD",6897,"KRN","B",.84,.84) "BLD",6897,"KRN","B",3.6,3.6) "BLD",6897,"KRN","B",3.8,3.8) "BLD",6897,"KRN","B",9.2,9.2) "BLD",6897,"KRN","B",9.8,9.8) "BLD",6897,"KRN","B",19,19) "BLD",6897,"KRN","B",19.1,19.1) "BLD",6897,"KRN","B",101,101) "BLD",6897,"KRN","B",409.61,409.61) "BLD",6897,"KRN","B",771,771) "BLD",6897,"KRN","B",870,870) "BLD",6897,"KRN","B",8989.51,8989.51) "BLD",6897,"KRN","B",8989.52,8989.52) "BLD",6897,"KRN","B",8994,8994) "BLD",6897,"QDEF") ^^^^NO^^^^NO^^YES "BLD",6897,"QUES",0) ^9.62^^ "BLD",6897,"REQB",0) ^9.611^12^12 "BLD",6897,"REQB",1,0) SD*5.3*417^2 "BLD",6897,"REQB",2,0) SD*5.3*80^2 "BLD",6897,"REQB",3,0) SD*5.3*269^2 "BLD",6897,"REQB",4,0) SD*5.3*357^2 "BLD",6897,"REQB",5,0) SD*5.3*478^2 "BLD",6897,"REQB",6,0) SD*5.3*376^2 "BLD",6897,"REQB",7,0) SD*5.3*397^2 "BLD",6897,"REQB",8,0) SD*5.3*467^2 "BLD",6897,"REQB",9,0) SD*5.3*427^2 "BLD",6897,"REQB",10,0) SD*5.3*280^2 "BLD",6897,"REQB",11,0) SD*5.3*266^2 "BLD",6897,"REQB",12,0) SD*5.3*358^2 "BLD",6897,"REQB","B","SD*5.3*266",11) "BLD",6897,"REQB","B","SD*5.3*269",3) "BLD",6897,"REQB","B","SD*5.3*280",10) "BLD",6897,"REQB","B","SD*5.3*357",4) "BLD",6897,"REQB","B","SD*5.3*358",12) "BLD",6897,"REQB","B","SD*5.3*376",6) "BLD",6897,"REQB","B","SD*5.3*397",7) "BLD",6897,"REQB","B","SD*5.3*417",1) "BLD",6897,"REQB","B","SD*5.3*427",9) "BLD",6897,"REQB","B","SD*5.3*467",8) "BLD",6897,"REQB","B","SD*5.3*478",5) "BLD",6897,"REQB","B","SD*5.3*80",2) "FIA",409.32) SD WL CLINIC LOCATION "FIA",409.32,0) ^SDWL(409.32, "FIA",409.32,0,0) 409.32IP "FIA",409.32,0,1) y^n^p^^^^n^^n "FIA",409.32,0,10) "FIA",409.32,0,11) "FIA",409.32,0,"RLRO") "FIA",409.32,0,"VR") 5.3^SD "FIA",409.32,409.32) 1 "FIA",409.32,409.32,.01) "FIA",409.32,409.32,.02) "FIA",409.32,409.32,3) "INIT") POST^SD53P491 "KRN",.401,1976,-1) 0^1 "KRN",.401,1976,0) SD-PAIT REJECTED APPT^3040415.1602^@^409.6^^@^3080507 "KRN",.401,1976,2,0) ^.4014^4^4 "KRN",.401,1976,2,1,0) 409.69^4^RETENTION FLAG^^^^^^^3 "KRN",.401,1976,2,1,1,0) ^.40141^1^1 "KRN",.401,1976,2,1,1,1,0) 409.6^1 "KRN",.401,1976,2,1,1,"B",409.6,1) "KRN",.401,1976,2,1,"F") Xz^Y^Y (YES - to be sent when 'Final') "KRN",.401,1976,2,1,"GET") S DISX(1)=$P($G(^SDWL(409.6,D0,1,D1,0)),U,5) "KRN",.401,1976,2,1,"IX") ^SDWL(409.6,"AE",^SDWL(409.6,^2 "KRN",.401,1976,2,1,"QCON") I DISX(1)="Y" "KRN",.401,1976,2,1,"T") Y^Y^Y (YES - to be sent when 'Final') "KRN",.401,1976,2,1,"TXT") RETENTION FLAG equals Y (YES - to be sent when 'Final') "KRN",.401,1976,2,2,0) 409.69^^ERROR MESSAGE^"7^^^^^^4 "KRN",.401,1976,2,2,1,0) ^.40141^1^1 "KRN",.401,1976,2,2,1,1,0) 409.6^1 "KRN",.401,1976,2,2,1,"B",409.6,1) "KRN",.401,1976,2,2,"CM") S Y(1)=$S($D(^SDWL(409.6,D0,1,D1,0)):^(0),1:"") S X=$P($G(^SCPT(404.472,+$P(Y(1),U,8),0)),U) I D1>0 S DISX(2)=X "KRN",.401,1976,2,2,"GET") S Y(1)=$S($D(^SDWL(409.6,D0,1,D1,0)):^(0),1:"") S X=$P($G(^SCPT(404.472,+$P(Y(1),U,8),0)),U) I D1>0 S DISX(2)=X "KRN",.401,1976,2,2,"QCON") I DISX(2)'="" "KRN",.401,1976,2,2,"TXT") ERROR MESSAGE not null "KRN",.401,1976,2,3,0) 409.69^^PATIENT^".01^^^^^^4 "KRN",.401,1976,2,3,1,0) ^.40141^1^1 "KRN",.401,1976,2,3,1,1,0) 409.6^1 "KRN",.401,1976,2,3,1,"B",409.6,1) "KRN",.401,1976,2,3,"CM") S Y(1)=$S($D(^SDWL(409.6,D0,1,D1,0)):^(0),1:"") S X=$P($G(^DPT(+$P(Y(1),U,1),0)),U) I D1>0 S DISX(3)=X "KRN",.401,1976,2,3,"GET") S Y(1)=$S($D(^SDWL(409.6,D0,1,D1,0)):^(0),1:"") S X=$P($G(^DPT(+$P(Y(1),U,1),0)),U) I D1>0 S DISX(3)=X "KRN",.401,1976,2,3,"QCON") I DISX(3)'="" "KRN",.401,1976,2,3,"TXT") PATIENT not null "KRN",.401,1976,2,4,0) 409.69^1^APPT DATE^^^^^^^1 "KRN",.401,1976,2,4,1,0) ^.40141^1^1 "KRN",.401,1976,2,4,1,1,0) 409.6^1 "KRN",.401,1976,2,4,1,"B",409.6,1) "KRN",.401,1976,2,4,"GET") S DISX(4)=$P($G(^SDWL(409.6,D0,1,D1,0)),U,2) "KRN",.401,1976,2,4,"QCON") I DISX(4)'="" "KRN",.401,1976,2,4,"TXT") APPT DATE not null "KRN",.401,1976,2,"B",409.69,1) "KRN",.401,1976,2,"B",409.69,2) "KRN",.401,1976,2,"B",409.69,3) "KRN",.401,1976,2,"B",409.69,4) "KRN",.401,1976,"%D",0) ^.4012^2^2^3060828^^^^ "KRN",.401,1976,"%D",1,0) This template will generate rejected appointments that are still in "KRN",.401,1976,"%D",2,0) pending status, ready to be transmitted. "KRN",.401,1976,"DIPT") "MBREQ") 0 "ORD",0,9.8) 9.8;;1;RTNF^XPDTA;RTNE^XPDTA "ORD",0,9.8,0) ROUTINE "ORD",6,.401) .401;6;;;EDEOUT^DIFROMSO(.401,DA,"",XPDA);FPRE^DIFROMSI(.401,"",XPDA);EPRE^DIFROMSI(.401,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.401,DA,"",XPDA);DEL^DIFROMSK(.401,"",%) "ORD",6,.401,0) SORT TEMPLATE "PKG",16,-1) 1^1 "PKG",16,0) SCHEDULING^SD^APPOINTMENTS,PROFILES,LETTERS,AMIS REPORTS "PKG",16,20,0) ^9.402P^^ "PKG",16,22,0) ^9.49I^1^1 "PKG",16,22,1,0) 5.3^2930813 "PKG",16,22,1,"PAH",1,0) 491^3080701^100892 "PKG",16,22,1,"PAH",1,1,0) ^^1^1^3080701 "PKG",16,22,1,"PAH",1,1,1,0) This patch addresses several EWL, PAIT, and Scheduling issues. "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") 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") 16 "RTN","SCRPW62") 0^2^B35851518^B30887240 "RTN","SCRPW62",1,0) SCRPW62 ;BP-CIOFO/KEITH - SC veterans awaiting appointments ; 23 August 2002@20:23 ; Compiled August 20, 2007 14:21:08 "RTN","SCRPW62",2,0) ;;5.3;Scheduling;**267,269,358,491**;AUG 13, 1993;Build 53 "RTN","SCRPW62",3,0) ; "RTN","SCRPW62",4,0) ;Prompt for report parameters "RTN","SCRPW62",5,0) ; "RTN","SCRPW62",6,0) N SDOUT,DIR,DTOUT,DUOUT,SDFMT,SDATES,SDDIV,SDRPT,SDSCVT "RTN","SCRPW62",7,0) N SDELIM,SDX,ZTSAVE,X,Y "RTN","SCRPW62",8,0) S SDOUT=0 "RTN","SCRPW62",9,0) D TITL^SCRPW50("SC Veterans Awaiting Appointments") "RTN","SCRPW62",10,0) W !,"Note: Once the scheduling replacement application has been implemented at your" "RTN","SCRPW62",11,0) W !,"site, this report will no longer be accurate." "RTN","SCRPW62",12,0) RPT D SUBT^SCRPW50("**** Report Type Selection ****") "RTN","SCRPW62",13,0) S DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND DATE DESIRED",DIR("A")="Select report type" "RTN","SCRPW62",14,0) S DIR("?",1)="Specify 'E' to return SC veterans entered but not yet provided an appointment," "RTN","SCRPW62",15,0) S DIR("?")="'A' to return SC veterans with appointments beyond the date desired." "RTN","SCRPW62",16,0) W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT "RTN","SCRPW62",17,0) K DIR S SDRPT=Y D ENT:SDRPT="E",APPT:SDRPT="A" G:SDOUT EXIT "RTN","SCRPW62",18,0) D SUBT^SCRPW50("**** Patient Eligibility Selection ****") "RTN","SCRPW62",19,0) S DIR(0)="S^1:50-100% SC Veterans;2:0-50% SC Veterans;3:All SC Veterans" "RTN","SCRPW62",20,0) S DIR("A")="Select eligibility type" "RTN","SCRPW62",21,0) S DIR("?")="Specify the eligibility of the patients you wish to include." "RTN","SCRPW62",22,0) W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT "RTN","SCRPW62",23,0) K DIR S SDSCVT=Y "RTN","SCRPW62",24,0) FMT D SUBT^SCRPW50("**** Report Format Selection ****") "RTN","SCRPW62",25,0) S DIR(0)="S^D:DETAILED REPORT;S:STATISTICS ONLY" "RTN","SCRPW62",26,0) S DIR("A")="Select report format" "RTN","SCRPW62",27,0) S DIR("?")="Specify the report format desired." "RTN","SCRPW62",28,0) W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT "RTN","SCRPW62",29,0) K DIR S SDFMT=Y "RTN","SCRPW62",30,0) I SDFMT="S" S SDELIM=0 G QUE "RTN","SCRPW62",31,0) D SUBT^SCRPW50("**** Output Format Selection ****") "RTN","SCRPW62",32,0) S DIR(0)="Y",DIR("A")="Return report output in delimited format" "RTN","SCRPW62",33,0) S DIR("B")="NO" "RTN","SCRPW62",34,0) S DIR("?",1)="Specify if you would like the report output to be in delimited format for" "RTN","SCRPW62",35,0) S DIR("?",2)="transfer to a spreadsheet. The delimited output will not include rated SC" "RTN","SCRPW62",36,0) S DIR("?")="disabilities for 0-50% SC veterans (as included in the text formatted report)." "RTN","SCRPW62",37,0) W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT "RTN","SCRPW62",38,0) S SDELIM=Y "RTN","SCRPW62",39,0) ; "RTN","SCRPW62",40,0) QUE ;Queue output "RTN","SCRPW62",41,0) ;W !!,"This report requires ",$S(SDELIM:"greater than ",1:""),"132 columns for output!" "RTN","SCRPW62",42,0) W !!,"This report requires the following steps to be converted to 'EXCEL':" "RTN","SCRPW62",43,0) W !,"1 - Copy it into WORD and replace '!^p' with null" "RTN","SCRPW62",44,0) W !,"2 - Save this file as *.txt format" "RTN","SCRPW62",45,0) W !,"3 - Open this file in 'EXCEL' with the All Files(*.*) type of file, listing it with one delimiter: '^'." "RTN","SCRPW62",46,0) F SDX="SDELIM","SDRPT","SDSCVT","SDATES","SDDIV","SDDIV(","SDFMT" S ZTSAVE(SDX)="" "RTN","SCRPW62",47,0) W ! D EN^XUTMDEVQ("START^SCRPW62","SC Veterans Awaiting Appointments",.ZTSAVE) D DISP0^SCRPW23 "RTN","SCRPW62",48,0) Q "RTN","SCRPW62",49,0) ; "RTN","SCRPW62",50,0) ENT ;Date entered parameters "RTN","SCRPW62",51,0) S SDATES=1 Q "RTN","SCRPW62",52,0) ; "RTN","SCRPW62",53,0) ;Following logic suppressed by request "RTN","SCRPW62",54,0) D SUBT^SCRPW50("**** Report Time Frame ****") "RTN","SCRPW62",55,0) S DIR(0)="S^1:THE PAST YEAR;2:THE PAST TWO YEARS;3:THE PAST 3 YEARS" "RTN","SCRPW62",56,0) S DIR("A")="Include SC veterans entered during" "RTN","SCRPW62",57,0) S DIR("?")="Specify the time frame in which these patients were entered in VistA." "RTN","SCRPW62",58,0) W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q "RTN","SCRPW62",59,0) S SDATES=Y "RTN","SCRPW62",60,0) Q "RTN","SCRPW62",61,0) ; "RTN","SCRPW62",62,0) APPT ;Appointment delay parameters "RTN","SCRPW62",63,0) I '$$DIVA^SCRPW17(.SDDIV) S SDOUT=1 Q "RTN","SCRPW62",64,0) S SDATES=30 Q "RTN","SCRPW62",65,0) ; "RTN","SCRPW62",66,0) ;Following logic suppressed by request "RTN","SCRPW62",67,0) D SUBT^SCRPW50("**** Report Time Frame ****") "RTN","SCRPW62",68,0) S DIR(0)="S^30:>30 DAYS BEYOND 'DESIRED DATE';60:>60 DAYS BEYOND 'DESIRED DATE;90:>90 DAYS BEYOND 'DESIRED DATE';180:>180 DAYS BEYOND 'DESIRED DATE'" "RTN","SCRPW62",69,0) S DIR("A")="Include SC veterans with future appointments greater than" "RTN","SCRPW62",70,0) S DIR("?")="Specify the difference between 'desired date' and the appointement date." "RTN","SCRPW62",71,0) W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q "RTN","SCRPW62",72,0) S SDATES=Y "RTN","SCRPW62",73,0) Q "RTN","SCRPW62",74,0) ; "RTN","SCRPW62",75,0) START ;Gather report data "RTN","SCRPW62",76,0) N SDSTOP,SDOUT,SDSTOP,SDPAGE,SDLINE,SDPNOW,SDT,SDX "RTN","SCRPW62",77,0) I '$D(ZTQUEUED),$E(IOST)="C" D WAIT^DICD "RTN","SCRPW62",78,0) K ^TMP("SCRPW",$J) S (SDSTOP,SDOUT)=0,SDPAGE=1,SDLINE="" "RTN","SCRPW62",79,0) S $P(SDLINE,"-",(IOM+1))="" "RTN","SCRPW62",80,0) S SDPNOW=$$FMTE^XLFDT($E($$NOW^XLFDT(),1,12)) "RTN","SCRPW62",81,0) S SDX=$S(SDSCVT=1:"SC 50-100% ",SDSCVT=2:"SC < 50% ",1:"") "RTN","SCRPW62",82,0) S SDT(1)="<*> SC VETERANS AWAITING APPOINTMENTS <*>" "RTN","SCRPW62",83,0) S SDT(2)=$S(SDRPT="E":SDX_"PATIENTS ENTERED IN THE PAST "_$S(SDATES=1:"YEAR",1:SDATES_" YEARS")_" WITHOUT AN APPOINTMENT",1:SDX_"PATIENTS WAITING > "_SDATES_" DAYS BEYOND APPOINTMENT 'DESIRED DATE'") "RTN","SCRPW62",84,0) D @(SDRPT_"^SCRPW63") W !! "RTN","SCRPW62",85,0) D EXIT "RTN","SCRPW62",86,0) Q "RTN","SCRPW62",87,0) ; "RTN","SCRPW62",88,0) SCEL(SDE,SDSCVT) ;Gather SC eligibility codes "RTN","SCRPW62",89,0) ;Input: SDE=array to return list of codes in the format SDE(n) where "RTN","SCRPW62",90,0) ; 'n' is the ifn in file #8 (pass by reference) "RTN","SCRPW62",91,0) ; SDSCVT=type of SC vets to include "RTN","SCRPW62",92,0) N SDE81,SDX,SDI,SDII "RTN","SCRPW62",93,0) S SDI=0 F S SDI=$O(^DIC(8.1,SDI)) Q:'SDI D "RTN","SCRPW62",94,0) .S SDX=$G(^DIC(8.1,SDI,0)) "RTN","SCRPW62",95,0) .Q:$P(SDX,U,5)'="Y" S SDX=$P(SDX,U,4) "RTN","SCRPW62",96,0) .I SDSCVT=1,SDX'=1 Q ;50-100% SC only "RTN","SCRPW62",97,0) .I SDSCVT=2,SDX'=3 Q ;0-50% SC only "RTN","SCRPW62",98,0) .I SDSCVT=3,(SDX'=1&(SDX'=3)) Q ;SC only "RTN","SCRPW62",99,0) .S SDII=0 F S SDII=$O(^DIC(8,"D",SDI,SDII)) Q:'SDII D "RTN","SCRPW62",100,0) ..S SDE(SDII)=SDX "RTN","SCRPW62",101,0) ..Q "RTN","SCRPW62",102,0) .Q "RTN","SCRPW62",103,0) Q "RTN","SCRPW62",104,0) ; "RTN","SCRPW62",105,0) EXIT K ZTQUEUED,ZTSTOP,SDATES,SDDIV,SDFMT,SDRPT,SDELIM "RTN","SCRPW62",106,0) D END^SCRPW50 Q "RTN","SCRPW62",107,0) ; "RTN","SCRPW62",108,0) HDR ;Print report header "RTN","SCRPW62",109,0) N X "RTN","SCRPW62",110,0) I SDELIM D HDRD Q "RTN","SCRPW62",111,0) I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT "RTN","SCRPW62",112,0) D STOP^SCRPW63 Q:SDOUT "RTN","SCRPW62",113,0) W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) "RTN","SCRPW62",114,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE "RTN","SCRPW62",115,0) S X=0 F S X=$O(SDT(X)) Q:'X W !?(IOM-$L(SDT(X))\2),SDT(X) "RTN","SCRPW62",116,0) W !,SDLINE,!,"Date printed: ",SDPNOW,?((IOM-6)-$L(SDPAGE)),"Page: " "RTN","SCRPW62",117,0) W SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q "RTN","SCRPW62",118,0) ; "RTN","SCRPW62",119,0) HDRD ;Header for delimited report "RTN","SCRPW62",120,0) Q:SDPAGE>1 "RTN","SCRPW62",121,0) W !,SDLINE S X=0 F S X=$O(SDT(X)) Q:'X W !,SDT(X) "RTN","SCRPW62",122,0) W !,"Date printed: ",SDPNOW,!,SDLINE "RTN","SCRPW62",123,0) N ARR S ARR(1)="NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER" "RTN","SCRPW62",124,0) S:SDRPT="A" ARR(1)=ARR(1)_"^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)" "RTN","SCRPW62",125,0) D DELIM(.ARR) "RTN","SCRPW62",126,0) S SDPAGE=SDPAGE+1 Q "RTN","SCRPW62",127,0) Q "RTN","SCRPW62",128,0) ;W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER" "RTN","SCRPW62",129,0) ;W:SDRPT="A" "^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)" "RTN","SCRPW62",130,0) ;S SDPAGE=SDPAGE+1 Q "RTN","SCRPW62",131,0) DELIM(ARR) ;enter delimiter in the end of wrapped line "RTN","SCRPW62",132,0) ;ARR - array of lines "RTN","SCRPW62",133,0) N DELIM,II,LN,LL,JJ "RTN","SCRPW62",134,0) S DELIM="!" "RTN","SCRPW62",135,0) F II=1:1 S LN=$G(ARR(II)),LL=$L(LN) Q:'LL S LN=$P(LN," ")_DELIM_$P(LN," ",2,$L(LN," ")) F JJ=1:79:LL W !,$E(LN,JJ,JJ+78) W:JJ+79(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT "RTN","SCRPW63",42,0) ...S SDX=^TMP("SCRPW",$J,SDEL,SDNAME,DFN) D PLINE(DFN,SDX,SDEL) "RTN","SCRPW63",43,0) ...Q "RTN","SCRPW63",44,0) .Q "RTN","SCRPW63",45,0) Q:SDOUT "RTN","SCRPW63",46,0) ESUM ;Print summary "RTN","SCRPW63",47,0) G:SDELIM EQ "RTN","SCRPW63",48,0) S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT "RTN","SCRPW63",49,0) W !! S SDYR="",SDTOT=0 "RTN","SCRPW63",50,0) F S SDYR=$O(^TMP("SCRPW",$J,"STATS",SDYR)) Q:SDYR="" D "RTN","SCRPW63",51,0) .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDYR,SDEL)) Q:'SDEL D "RTN","SCRPW63",52,0) ..S SDX=$$CSCEL(SDEL)_" veterans entered "_$S(SDYR=0:"in the past year",SDYR=1:"two years ago",SDYR=2:"three years ago",1:"")_":" "RTN","SCRPW63",53,0) ..W !?36,$J(SDX,45),?83,$J(^TMP("SCRPW",$J,"STATS",SDYR,SDEL),6,0) "RTN","SCRPW63",54,0) ..S SDTOT=SDTOT+^TMP("SCRPW",$J,"STATS",SDYR,SDEL) "RTN","SCRPW63",55,0) ..Q "RTN","SCRPW63",56,0) .Q "RTN","SCRPW63",57,0) W !?36,$E(SDLINE,1,53),!?75,"TOTAL:",?83,$J(SDTOT,6,0) "RTN","SCRPW63",58,0) EQ I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" W !! D ^DIR "RTN","SCRPW63",59,0) Q "RTN","SCRPW63",60,0) ; "RTN","SCRPW63",61,0) SCHAPP(DFN) ;Look for scheduled appointments not cancelled by clinic "RTN","SCRPW63",62,0) ; Input: DFN=patient ifn "RTN","SCRPW63",63,0) ;Output: '1' if appointments exist, '0' otherwise "RTN","SCRPW63",64,0) N SDI,SDX,SDY "RTN","SCRPW63",65,0) S (SDI,SDY)=0 "RTN","SCRPW63",66,0) F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI!SDY D "RTN","SCRPW63",67,0) .S SDX=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDX) "RTN","SCRPW63",68,0) .S SDX=$P(SDX,U,2) I $L(SDX),"CA"[SDX Q "RTN","SCRPW63",69,0) .S SDY=1 "RTN","SCRPW63",70,0) .Q "RTN","SCRPW63",71,0) Q SDY "RTN","SCRPW63",72,0) ; "RTN","SCRPW63",73,0) A ;Gather data for future appointments report "RTN","SCRPW63",74,0) N DFN,SDA0,SDX,SDI,SDSCEL,SDEL,SDDATE,SDIFF,SDAPT,SDIVL,SDIVN "RTN","SCRPW63",75,0) N SDREL,SDTOT,SDIV,SD0,SDNAME "RTN","SCRPW63",76,0) D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers "RTN","SCRPW63",77,0) S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN!SDSTOP D "RTN","SCRPW63",78,0) .I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request "RTN","SCRPW63",79,0) .S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL)) ;Only SC vets "RTN","SCRPW63",80,0) .S SDEL=SDSCEL(SDEL) "RTN","SCRPW63",81,0) .Q:+$G(^DPT(DFN,.35)) ;No deceased patients "RTN","SCRPW63",82,0) .S SDI=DT F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI D "RTN","SCRPW63",83,0) ..S SDDATE=+$G(^DPT(DFN,"S",SDI,1)) Q:'SDDATE Q:SDDATE>SDI "RTN","SCRPW63",84,0) ..S SDA0=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDA0) "RTN","SCRPW63",85,0) ..S SDIV=$P($G(^SC(+SDA0,0)),U,15) Q:'$$DIV(.SDIV) ;Division check "RTN","SCRPW63",86,0) ..;Exclude cancelled appointments "RTN","SCRPW63",87,0) ..S SDX=$P(SDA0,U,2) I $L(SDX),"PCA"[SDX Q "RTN","SCRPW63",88,0) ..S SDIFF=$$FMDIFF^XLFDT(SDI,SDDATE) Q:SDIFF'>SDATES "RTN","SCRPW63",89,0) ..S SDNAME=$P($G(^DPT(DFN,0)),U) Q:'$L(SDNAME) "RTN","SCRPW63",90,0) ..;Record detailed information "RTN","SCRPW63",91,0) ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)=SDDATE_U_SDA0 "RTN","SCRPW63",92,0) ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)=$G(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN))+1 "RTN","SCRPW63",93,0) ..Q "RTN","SCRPW63",94,0) .Q "RTN","SCRPW63",95,0) Q:SDSTOP "RTN","SCRPW63",96,0) ;Tally up statistics "RTN","SCRPW63",97,0) S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV D "RTN","SCRPW63",98,0) .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL D "RTN","SCRPW63",99,0) ..S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D "RTN","SCRPW63",100,0) ...S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN D "RTN","SCRPW63",101,0) ....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS"))+1 "RTN","SCRPW63",102,0) ....S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D "RTN","SCRPW63",103,0) .....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"))+1 "RTN","SCRPW63",104,0) .....Q "RTN","SCRPW63",105,0) ....Q "RTN","SCRPW63",106,0) ...Q "RTN","SCRPW63",107,0) ..Q "RTN","SCRPW63",108,0) .Q "RTN","SCRPW63",109,0) Q:SDSTOP "RTN","SCRPW63",110,0) ;Print report "RTN","SCRPW63",111,0) S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV "RTN","SCRPW63",112,0) I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" D "RTN","SCRPW63",113,0) .S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE() "RTN","SCRPW63",114,0) .Q "RTN","SCRPW63",115,0) I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 D "RTN","SCRPW63",116,0) .F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI D "RTN","SCRPW63",117,0) ..S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI "RTN","SCRPW63",118,0) ..Q "RTN","SCRPW63",119,0) .Q "RTN","SCRPW63",120,0) D:$E(IOST)="C" DISP0^SCRPW23 "RTN","SCRPW63",121,0) I '$D(^TMP("SCRPW",$J)) D Q ;Negative report "RTN","SCRPW63",122,0) .S SDIV=0 D DHDR^SCRPW40(3,.SDT),HDR^SCRPW62 "RTN","SCRPW63",123,0) .S SDX="No appointments found that meet report criteria." "RTN","SCRPW63",124,0) .I SDELIM W !,SDX Q "RTN","SCRPW63",125,0) .W !!?(IOM-$L(SDX)\2),SDX "RTN","SCRPW63",126,0) .I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR "RTN","SCRPW63",127,0) .Q "RTN","SCRPW63",128,0) G:SDFMT="S" ASUM "RTN","SCRPW63",129,0) ;Print detailed report by division "RTN","SCRPW63",130,0) S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT D "RTN","SCRPW63",131,0) .S SDIV=SDIV(SDIVN) D ADPRT(.SDIV) "RTN","SCRPW63",132,0) .Q "RTN","SCRPW63",133,0) Q:SDOUT "RTN","SCRPW63",134,0) ;Print summary "RTN","SCRPW63",135,0) ASUM G:SDELIM AQ "RTN","SCRPW63",136,0) S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT "RTN","SCRPW63",137,0) W !! S (SDTOT,SDIV,SDIVL)=0,SDIVN="" "RTN","SCRPW63",138,0) F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN="" D "RTN","SCRPW63",139,0) .S SDIVN(SDIV(SDIVN))=SDIVN S:$L(SDIVN)>SDIVL SDIVL=$L(SDIVN) "RTN","SCRPW63",140,0) F S SDIV=$O(^TMP("SCRPW",$J,"STATS",SDIV)) Q:'SDIV D "RTN","SCRPW63",141,0) .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDIV,SDEL)) Q:'SDEL D "RTN","SCRPW63",142,0) ..S SDAPT=^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"),SDTOT=SDTOT+SDAPT "RTN","SCRPW63",143,0) ..S SDX=$$CSCEL(SDEL)_" appointments at "_SDIVN(SDIV)_":" "RTN","SCRPW63",144,0) ..W !?(50-SDIVL),$J(SDX,(28+SDIVL)),?80,$J(SDAPT,6,0) "RTN","SCRPW63",145,0) ..Q "RTN","SCRPW63",146,0) .Q "RTN","SCRPW63",147,0) W !?(50-SDIVL),$E(SDLINE,1,(36+SDIVL)),!?72,"TOTAL:",?80,$J(SDTOT,6,0) "RTN","SCRPW63",148,0) AQ I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR "RTN","SCRPW63",149,0) Q "RTN","SCRPW63",150,0) ; "RTN","SCRPW63",151,0) DIV(SDIV) ;Check division "RTN","SCRPW63",152,0) S:'$L(SDIV) SDIV=$$PRIM^VASITE() "RTN","SCRPW63",153,0) Q:'SDDIV 1 Q $D(SDDIV(+SDIV)) "RTN","SCRPW63",154,0) ; "RTN","SCRPW63",155,0) ; "RTN","SCRPW63",156,0) STOP ;Check for stop task request "RTN","SCRPW63",157,0) S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q "RTN","SCRPW63",158,0) ; "RTN","SCRPW63",159,0) ADPRT(SDIV) ;Print report for a division "RTN","SCRPW63",160,0) D DHDR^SCRPW40(3,.SDT) S:SDELIM SDPAGE=1 "RTN","SCRPW63",161,0) I '$D(^TMP("SCRPW",$J,SDIV)) D HDR^SCRPW62 Q:SDOUT D Q "RTN","SCRPW63",162,0) .S SDX="No appointments found for this division within report parameters!" "RTN","SCRPW63",163,0) .I SDELIM W !,SDX Q "RTN","SCRPW63",164,0) .W !!?(132-$L(SDX)\2),SDX Q "RTN","SCRPW63",165,0) D HDR^SCRPW62 Q:SDOUT "RTN","SCRPW63",166,0) S SDEL="" F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL!SDOUT D "RTN","SCRPW63",167,0) .S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D "RTN","SCRPW63",168,0) ..S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT D "RTN","SCRPW63",169,0) ...S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0) "RTN","SCRPW63",170,0) ...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4)) "RTN","SCRPW63",171,0) ...S SDREL=SDREL+^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN) "RTN","SCRPW63",172,0) ...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT "RTN","SCRPW63",173,0) ...D PLINE(DFN,SD0,SDEL) "RTN","SCRPW63",174,0) ...Q "RTN","SCRPW63",175,0) ..Q "RTN","SCRPW63",176,0) .Q "RTN","SCRPW63",177,0) Q "RTN","SCRPW63",178,0) ; "RTN","SCRPW63",179,0) PLINE(DFN,SD0,SDEL) ;Print patient detail line "RTN","SCRPW63",180,0) ;Input: DFN=patient ifn "RTN","SCRPW63",181,0) ; SD0=zeroeth node of patient record "RTN","SCRPW63",182,0) ; SDEL=1 or 3 to denote SC > or < 50% "RTN","SCRPW63",183,0) ; "RTN","SCRPW63",184,0) N SDSSN,SDNAME,SDDTE,SDADD,SDST,SDX,SDI,SDY,SDELN,SDZIP,SDZ,SDZA,SDII "RTN","SCRPW63",185,0) S SDNAME=$P(SD0,U),SDSSN=$P(SD0,U,9),SDDTE=$$FMTE^XLFDT($P(SD0,U,16)) "RTN","SCRPW63",186,0) S SDSSN=$E(SDSSN,1,3)_"-"_$E(SDSSN,4,5)_"-"_$E(SDSSN,6,10) "RTN","SCRPW63",187,0) S SDEL=$G(SDEL),SDELN=$$CSCEL(SDEL),SDADD=$G(^DPT(DFN,.11)) "RTN","SCRPW63",188,0) S SDST=$P($G(^DIC(5,+$P(SDADD,U,5),0)),U,2),SDZIP=$P(SDADD,U,12) "RTN","SCRPW63",189,0) S:$L(SDZIP)=9 SDZIP=$E(SDZIP,1,5)_"-"_$E(SDZIP,6,9) "RTN","SCRPW63",190,0) I SDELIM D ;Set up delimited output "RTN","SCRPW63",191,0) .S SDZ=SDNAME_U_SDSSN_U_SDELN_U_SDDTE_U_$P(SDADD,U)_U_$P(SDADD,U,4) "RTN","SCRPW63",192,0) .S SDZ=SDZ_U_SDST_U_SDZIP_U_$P($G(^DPT(DFN,.13)),U) "RTN","SCRPW63",193,0) .Q "RTN","SCRPW63",194,0) I 'SDELIM D "RTN","SCRPW63",195,0) .;Print name, SSN, eligibility, date entered, address and phone number "RTN","SCRPW63",196,0) .W !,"Name: ",SDNAME,?39,"SSN: ",SDSSN,?58,"Prim. Elig.: ",SDELN "RTN","SCRPW63",197,0) .W ?84,"Date entered: ",SDDTE,!?10,"Address: ",$P(SDADD,U) "RTN","SCRPW63",198,0) .W ?55,$P(SDADD,U,4),$S($L($P(SDADD,U,4)):", ",1:""),SDST," ",SDZIP "RTN","SCRPW63",199,0) .W ?88,"Phone number: ",$P($G(^DPT(DFN,.13)),U) "RTN","SCRPW63",200,0) .;Print SC disabilities for 0-50% SC veterans "RTN","SCRPW63",201,0) .I SDEL=3 S SDI=0 F S SDI=$O(^DPT(DFN,.372,SDI)) Q:'SDI D "RTN","SCRPW63",202,0) ..S SDX=$G(^DPT(DFN,.372,SDI,0)) Q:'$P(SDX,U,3) "RTN","SCRPW63",203,0) ..S SDY=$G(^DIC(31,+SDX,0)) Q:'$L(SDY) "RTN","SCRPW63",204,0) ..W !?20,"SC disability: ",$P(SDY,U,3)," ",$P(SDY,U) "RTN","SCRPW63",205,0) ..W ?89,"%SC: ",$P(SDX,U,2) "RTN","SCRPW63",206,0) ..Q "RTN","SCRPW63",207,0) .Q "RTN","SCRPW63",208,0) I SDRPT="E" D Q "RTN","SCRPW63",209,0) .I SDELIM S SDZ(1)=SDZ D DELIM^SCRPW62(.SDZ) Q ;W !,SDZ Q "RTN","SCRPW63",210,0) .W ! "RTN","SCRPW63",211,0) .Q "RTN","SCRPW63",212,0) ;Print appointment details for future appointment report "RTN","SCRPW63",213,0) S SDI=0 D "RTN","SCRPW63",214,0) .F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D "RTN","SCRPW63",215,0) ..S SDA0=^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI) "RTN","SCRPW63",216,0) ..I 'SDELIM D "RTN","SCRPW63",217,0) ...W !?30,"Appointment: ",$$FMTE^XLFDT(SDI) "RTN","SCRPW63",218,0) ...W ?63,$P($G(^SC(+$P(SDA0,U,2),0)),U),?96,"Desired date: " "RTN","SCRPW63",219,0) ...W $$FMTE^XLFDT(+SDA0),?124,"(",$$FMDIFF^XLFDT(SDI,+SDA0),")" "RTN","SCRPW63",220,0) ...Q "RTN","SCRPW63",221,0) ..I SDELIM D ;Delimited output "RTN","SCRPW63",222,0) ...N SDC0,SDCP,SDCZ,SDADM,SDADME "RTN","SCRPW63",223,0) ...S SDC0=$G(^SC(+$P(SDA0,U,2),0)),SDCZ=$$CPAIR^SCRPW71(SDC0,.SDCP) "RTN","SCRPW63",224,0) ...S SDII=0,(SDZA,SDADM,SDADME)="" "RTN","SCRPW63",225,0) ...F S SDII=$O(^SC(+$P(SDA0,U,2),"S",SDI,1,SDII)) D Q:'SDII "RTN","SCRPW63",226,0) ....Q:+$G(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0))'=DFN "RTN","SCRPW63",227,0) ....S SDADM=$P(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0),U,7) "RTN","SCRPW63",228,0) ....S SDADME=$$FMTE^XLFDT(SDADM),SDII=0 "RTN","SCRPW63",229,0) ....Q "RTN","SCRPW63",230,0) ...S SDCZ=SDCP_U_$P($$SITE^VASITE(,$P(SDC0,U,15)),U,2)_U_SDADME "RTN","SCRPW63",231,0) ...S SDZA=SDZA_U_$$FMTE^XLFDT(SDI)_U_$P(SDC0,U)_U_SDCZ "RTN","SCRPW63",232,0) ...S SDZA=SDZA_U_$$FMTE^XLFDT(+SDA0)_U_$$FMDIFF^XLFDT(SDI,+SDA0) "RTN","SCRPW63",233,0) ...S SDZA=SDZA_U_$S(SDADM:$$FMDIFF^XLFDT(+SDA0,SDADM),1:"") "RTN","SCRPW63",234,0) ...S SDZ(1)=SDZ_SDZA "RTN","SCRPW63",235,0) ...D DELIM^SCRPW62(.SDZ) ;W !,SDZ,SDZA "RTN","SCRPW63",236,0) ...Q "RTN","SCRPW63",237,0) ..Q "RTN","SCRPW63",238,0) .Q "RTN","SCRPW63",239,0) W:'SDELIM ! Q "RTN","SCRPW63",240,0) ; "RTN","SCRPW63",241,0) CSCEL(SDEL) ;Convert SC elig. to external "RTN","SCRPW63",242,0) Q $S(SDEL=1:"SC 50-100%",SDEL=3:"SC < 50%",1:"") "RTN","SD53P491") 0^^B90496427^n/a "RTN","SD53P491",1,0) SD53P491 ;ALB/ESW - SD*5.3*491 POST INIT; Oct 04, 2006 ; 10/23/06 5:40pm ; Compiled June 17, 2008 10:41:32 "RTN","SD53P491",2,0) ;;5.3;SCHEDULING;**491**;AUG 13, 1993;Build 53 "RTN","SD53P491",3,0) ;Remove trigger - field .01 in the SD WL CLINIC LOCATION file (# 409.32) "RTN","SD53P491",4,0) ;Verify setup of Billable Appointment type: ein=11 - SC "RTN","SD53P491",5,0) ;Update encounters with Appointment Type matching the SC set up on the encounter level "RTN","SD53P491",6,0) ;Update file 409.32 and 409.3 with proper institution set up "RTN","SD53P491",7,0) ;Retransmission of updated encounters has been disabled "RTN","SD53P491",8,0) Q "RTN","SD53P491",9,0) ; "RTN","SD53P491",10,0) POST ; "RTN","SD53P491",11,0) N SDA "RTN","SD53P491",12,0) S SDA(1)="",SDA(2)=" SD*5.3*491 Post-Install .....",SDA(3)="" D ATADDQ "RTN","SD53P491",13,0) N SDA "RTN","SD53P491",14,0) S SDA(1)="",SDA(2)=" Deleting cross-reference definition - trigger of the CLINIC field" "RTN","SD53P491",15,0) S SDA(3)=" in the SD WL CLINIC LOCATION file (# 409.32)",SDA(4)="" "RTN","SD53P491",16,0) D DELIX^DDMOD(409.32,.01,2,"K") D ATADDQ "RTN","SD53P491",17,0) ; "RTN","SD53P491",18,0) D ATADD ; Verify Billable Appointment Type: ien=11 "RTN","SD53P491",19,0) ; ^IBE(352.1,11,0)=11^11^2880101^0^1^1 "RTN","SD53P491",20,0) S SDA(1)="",SDA(2)=" SD*5.3*491 SC Billable Appointment Type error checking is complete",SDA(3)="" D ATADDQ "RTN","SD53P491",21,0) N SDA "RTN","SD53P491",22,0) S SDA(1)="",SDA(2)="Starting Appointment Type verification for Outpatient Encounter file entries",SDA(3)="with encounter-level Service Connection for encounter entries created",SDA(4)="Jan 20, 2006 or later",SDA(5)="" D ATADDQ "RTN","SD53P491",23,0) ; "RTN","SD53P491",24,0) D CHKSC "RTN","SD53P491",25,0) N SDA "RTN","SD53P491",26,0) S SDA(1)="",SDA(2)="Appointment Type correction to file 409.68 and to sub-file 2.98 finished.",SDA(3)="" D ATADDQ "RTN","SD53P491",27,0) ; "RTN","SD53P491",28,0) N SDA "RTN","SD53P491",29,0) S SDA(1)="",SDA(2)="Checking file 409.32 and 409.3 for valid national institutions, and pointers",SDA(3)="that don't match institutions of the Medical Center Division of their related",SDA(4)="Hospital Location",SDA(5)="" D ATADDQ "RTN","SD53P491",30,0) N INERROR,SDWLSC,SDX,CNT S INERROR="" "RTN","SD53P491",31,0) S SDX(1)="Checking file 409.32 and 409.3 for valid national institutions, and pointers" "RTN","SD53P491",32,0) S SDX(2)="that don't match institutions of the Medical Center Division of their related" "RTN","SD53P491",33,0) S SDX(3)="Hospital Location" "RTN","SD53P491",34,0) S SDX(4)="",CNT=4 S SDWLSC=0 F S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC D UPDINS(SDWLSC,.CNT,.INERROR) "RTN","SD53P491",35,0) D MSGG(.SDX) "RTN","SD53P491",36,0) Q:INERROR "RTN","SD53P491",37,0) N DIK S DIK="SDWL(409.32," D IXALL^DIK "RTN","SD53P491",38,0) N SDA "RTN","SD53P491",39,0) S SDA(1)="",SDA(2)="Verification and update of files 409.32 and 409.3",SDA(3)=" with proper institution finished.",SDA(4)="",SDA(5)=" SD*5.3*491 Post-Install finished...." "RTN","SD53P491",40,0) D ATADDQ "RTN","SD53P491",41,0) Q "RTN","SD53P491",42,0) ; "RTN","SD53P491",43,0) ATADD ; New Billable Appointment Type (352.1) to correspond to the New 'SERVICE CONNECTED' Appointment Type (409.1) "RTN","SD53P491",44,0) N DD,DO,DLAYGO,DINUM,DIC,DIE,DA,DR,X,Y,SDA,IBFOUND,SDATFN,IBNUM,SDAT,IBFN "RTN","SD53P491",45,0) S SDA(1)=" >> Verifying 'Service Connected' Billable Appointment Type (#352.1)" "RTN","SD53P491",46,0) S (SDATFN,IBNUM)=11,SDAT="SERVICE CONNECTED" "RTN","SD53P491",47,0) S IBFOUND=$G(^IBE(352.1,SDATFN,0)) ; new IA confirmed to be created "RTN","SD53P491",48,0) I IBFOUND="11^11^2880101^0^1^1" D D ATADDQ Q "RTN","SD53P491",49,0) .D MSG(" Done. Billable Appointment Type Service Connected is set up properly") "RTN","SD53P491",50,0) D MSG(" "),MSG("* ERROR IN CONFIGURATION OF ENTRY IEN=11 IN FILE 352.1 *") "RTN","SD53P491",51,0) D MSG("IT IS MANDATORY THAT YOU CREATE AN INTEGRATED BILLING REMEDY TICKET"),MSG("Entry 11 should be configured for the SERVICE CONNECTED appointment type.") "RTN","SD53P491",52,0) D MSG(" --------------------------") D ATADDQ "RTN","SD53P491",53,0) Q "RTN","SD53P491",54,0) ATADDQ D MES^XPDUTL(.SDA) K SDA "RTN","SD53P491",55,0) Q "RTN","SD53P491",56,0) CHKSC ;Match SC encounter value with proper Appointment Type. "RTN","SD53P491",57,0) ; look for encounters only "RTN","SD53P491",58,0) N SCE,CNT,CNTA S CNT=0,CNTA=0 "RTN","SD53P491",59,0) ;SCE - EIN of Outpatient Encounter "RTN","SD53P491",60,0) K ^XTMP("SD53P491-"_$J),^XTMP("SD53P491AP-"_$J) "RTN","SD53P491",61,0) S ^XTMP("SD53P491-"_$J,0)=$$FMADD^XLFDT(""_DT_"",7)_U_DT "RTN","SD53P491",62,0) S ^XTMP("SD53P491AP-"_$J,0)=$$FMADD^XLFDT(""_DT_"",7)_U_DT "RTN","SD53P491",63,0) S SCE=0 "RTN","SD53P491",64,0) F S SCE=$O(^SCE(SCE)) Q:SCE'>0 I $P($G(^SCE(SCE,"USER")),U,4)>3060120 D "RTN","SD53P491",65,0) .N STR,SDSCV,SDT,SDVST,DFN,SDAPDF,SDVSCL S STR=$G(^SCE(SCE,0)) "RTN","SD53P491",66,0) .S DFN=$P(STR,U,2),SDT=+STR,SDVSCL=$P(STR,U,4) "RTN","SD53P491",67,0) .S SDVST=$P($G(STR),U,5) "RTN","SD53P491",68,0) .Q:'SDVST Q:'$D(^AUPNVSIT(SDVST,800)) "RTN","SD53P491",69,0) .S SDSCV=$$GET1^DIQ(9000010,SDVST_",",80001,"I") ;SC flag in Visit file "RTN","SD53P491",70,0) .Q:SDSCV="" ;do not proceed if SC not determined "RTN","SD53P491",71,0) .S SDAPDF=$$GET1^DIQ(44,SDVSCL_",",2507,"I") ;default appt type "RTN","SD53P491",72,0) .I SDAPDF'="" S SDAPDPT=SDAPDF ; set to default if exists for this clinic "RTN","SD53P491",73,0) .E S SDAPDPT=9 ; set to regular "RTN","SD53P491",74,0) .N UPDAP I SDSCV S UPDAP=11 "RTN","SD53P491",75,0) .E S UPDAP=SDAPDPT "RTN","SD53P491",76,0) .N SDR D APPT(DFN,SDT,SCE,UPDAP,.SDR) "RTN","SD53P491",77,0) .I $P(^SCE(SCE,0),U,10)=11 D ; change only if original appt type was SC "RTN","SD53P491",78,0) ..Q:SDSCV "RTN","SD53P491",79,0) ..M ^XTMP("SD53P491-"_$J,DFN,SDT,SCE)=^SCE(SCE,0) S CNT=CNT+1 "RTN","SD53P491",80,0) ..S $P(^SCE(SCE,0),U,10)=SDAPDPT "RTN","SD53P491",81,0) ..;I 'SDR D RETR(SCE) "RTN","SD53P491",82,0) .E D "RTN","SD53P491",83,0) ..Q:'SDSCV "RTN","SD53P491",84,0) ..; change only if original appt type was SC "RTN","SD53P491",85,0) ..M ^XTMP("SD53P491-"_$J,DFN,SDT,SCE)=^SCE(SCE,0) S CNT=CNT+1 "RTN","SD53P491",86,0) ..S $P(^SCE(SCE,0),U,10)=11 "RTN","SD53P491",87,0) ..;I 'SDR D RETR(SCE) "RTN","SD53P491",88,0) .D CRST(SDVST,SDSCV,SDAPDPT,.CNT) "RTN","SD53P491",89,0) N SDA "RTN","SD53P491",90,0) S SDA(1)="",SDA(2)=" "_CNT_" OUTPATIENT ENCOUNTER entry(ies) updated with an Appointment Type." "RTN","SD53P491",91,0) S SDA(3)=" "_CNTA_" APPOINTMENT Multiple entry(ies) in the PATIENT file updated" "RTN","SD53P491",92,0) S SDA(4)=" "_"with an Appointment Type." "RTN","SD53P491",93,0) S SDA(5)="" "RTN","SD53P491",94,0) D ATADDQ "RTN","SD53P491",95,0) Q "RTN","SD53P491",96,0) APPT(DFN,SDT,SCE,UPDAP,SDR) ;update appointment multiple in Patient file "RTN","SD53P491",97,0) N STR S STR=$G(^DPT(DFN,"S",SDT,0)) "RTN","SD53P491",98,0) S SDR=0 "RTN","SD53P491",99,0) I $P(STR,U,20)'=SCE Q "RTN","SD53P491",100,0) I $P(STR,U,16)'=UPDAP D "RTN","SD53P491",101,0) .M ^XTMP("SD53P491AP-"_$J,DFN,SDT,SCE)=STR "RTN","SD53P491",102,0) .S $P(^DPT(DFN,"S",SDT,0),U,16)=UPDAP "RTN","SD53P491",103,0) .S CNTA=CNTA+1,SDR=1 "RTN","SD53P491",104,0) .;I SDR D RETR(SCE) "RTN","SD53P491",105,0) Q "RTN","SD53P491",106,0) RETR(SCE) ; mark encounter for retransmission "RTN","SD53P491",107,0) N SDXM "RTN","SD53P491",108,0) S SDXM=$$FINDXMIT^SCDXFU01(SCE) "RTN","SD53P491",109,0) D STREEVNT^SCDXFU01(SDXM,2) "RTN","SD53P491",110,0) D XMITFLAG^SCDXFU01(SDXM) "RTN","SD53P491",111,0) Q "RTN","SD53P491",112,0) MSG(X) ; "RTN","SD53P491",113,0) N SDX S SDX=$O(SDA(999999),-1) S:'SDX SDX=1 S SDX=SDX+1 "RTN","SD53P491",114,0) S SDA(SDX)=$G(X) "RTN","SD53P491",115,0) Q "RTN","SD53P491",116,0) CRST(SDVST,SDSCV,SDAPDPT,CNT) ;check for credit stop encounter for each scanned encounter "RTN","SD53P491",117,0) N SDVSTS,SDE S SDE="" S SDVSTS=$O(^AUPNVSIT("AD",SDVST,"")) ; only one child visit "RTN","SD53P491",118,0) I SDVSTS>0 S SDE=$O(^SCE("AVSIT",SDVSTS,"")) "RTN","SD53P491",119,0) Q:'SDE "RTN","SD53P491",120,0) I SDSCV D "RTN","SD53P491",121,0) .I $P(^SCE(SDE,0),U,10)'=11 D "RTN","SD53P491",122,0) ..M ^XTMP("SD53P491-"_$J,DFN,SDT,SDE,1)=^SCE(SDE,0) S CNT=CNT+1 "RTN","SD53P491",123,0) ..S $P(^SCE(SDE,0),U,10)=11 "RTN","SD53P491",124,0) ..;D RETR(SDE) "RTN","SD53P491",125,0) I 'SDSCV D "RTN","SD53P491",126,0) .I $P(^SCE(SDE,0),U,10)=11 D "RTN","SD53P491",127,0) ..M ^XTMP("SD53P491-"_$J,DFN,SDT,SDE,1)=^SCE(SDE,0) S CNT=CNT+1 "RTN","SD53P491",128,0) ..S $P(^SCE(SDE,0),U,10)=SDAPDPT "RTN","SD53P491",129,0) ..;D RETR(SDE) "RTN","SD53P491",130,0) Q "RTN","SD53P491",131,0) UPDINS(SDWLSC,CNT,INERROR) ; update 409.32 and the related entries in 409.3 "RTN","SD53P491",132,0) N SDWLINS S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") ; current set up IN 409.32 "RTN","SD53P491",133,0) ;check set up in file 44 "RTN","SD53P491",134,0) ;get clinic "RTN","SD53P491",135,0) N CL,CLN S CL=$$GET1^DIQ(409.32,SDWLSC_",",.01,"I"),CLN=$$GET1^DIQ(44,CL_",",.01) "RTN","SD53P491",136,0) N STR,SDWMES S SDWMES="",STR=$$CLIN^SDWLPE(CL) "RTN","SD53P491",137,0) S SDWMES=SDWMES_$P(STR,U,6) "RTN","SD53P491",138,0) I $P(STR,U,5)="L" S CNT=CNT+1 S (SDWMES,SDX(CNT))=SDWMES_" - Local Institution assigned to clinic. " "RTN","SD53P491",139,0) I SDWMES'="" D Q "RTN","SD53P491",140,0) .S CNT=CNT+1,SDX(CNT)=" ** Invalid configuration of Clinic "_CLN_" ("_CL_")"_": **" "RTN","SD53P491",141,0) .W !!,SDX(CNT) "RTN","SD53P491",142,0) .S CNT=CNT+1,SDX(CNT)=SDWMES "RTN","SD53P491",143,0) .W !,SDX(CNT) "RTN","SD53P491",144,0) .S CNT=CNT+1,SDX(CNT)="YOU MUST UPDATE THIS FILE 44 ENTRY'S DIVISION OR ITS MEDICAL CENTER DIVISION'S" "RTN","SD53P491",145,0) .W !,SDX(CNT) "RTN","SD53P491",146,0) .S CNT=CNT+1,SDX(CNT)="INSTITUTION FILE POINTER." "RTN","SD53P491",147,0) .W !,SDX(CNT) "RTN","SD53P491",148,0) .S CNT=CNT+1,SDX(CNT)="" "RTN","SD53P491",149,0) .S:INERROR="" INERROR=1 Q "RTN","SD53P491",150,0) I +STR'=SDWLINS D "RTN","SD53P491",151,0) .S CNT=CNT+1,SDX(CNT)="The Medical Center Division for file 44 Clinic "_CLN_" ("_CL_")" "RTN","SD53P491",152,0) .W !!,SDX(CNT) "RTN","SD53P491",153,0) .S CNT=CNT+1,SDX(CNT)="has a different Institution than the file 409.32 entry for EWL." "RTN","SD53P491",154,0) .W !,SDX(CNT) "RTN","SD53P491",155,0) .N SDI,SDI1 S SDI=$$GET1^DIQ(4,SDWLINS_",",.01),SDI1=$$GET1^DIQ(4,SDWLINS_",",99) "RTN","SD53P491",156,0) .S CNT=CNT+1,SDX(CNT)="EWL Clinic INSTITUTION: "_SDI_" - "_SDI1 "RTN","SD53P491",157,0) .W !,SDX(CNT) "RTN","SD53P491",158,0) .S CNT=CNT+1,SDX(CNT)="Clinic INSTITUTION: "_$P(STR,U,3)_" - "_$P(STR,U,2) "RTN","SD53P491",159,0) .W !,SDX(CNT) "RTN","SD53P491",160,0) .N DIE,DR,DA S DR=".02////^S X=+STR",DIE="^SDWL(409.32,",DA=SDWLSC "RTN","SD53P491",161,0) .L +^SDWL(409.32,DA):0 I '$T S CNT=CNT+1,SDX(CNT)="Entry locked; Run SD WAIT LIST CLEANUP later" W !?5,SDX(CNT) Q "RTN","SD53P491",162,0) .D ^DIE L -^SDWL(409.32,DA) "RTN","SD53P491",163,0) .S CNT=CNT+1,SDX(CNT)="Updated EWL Clinic to match." "RTN","SD53P491",164,0) .W !,SDX(CNT),! "RTN","SD53P491",165,0) .S CNT=CNT+1,SDX(CNT)="" "RTN","SD53P491",166,0) .;loop to update EWL entries in FILE 409.3 if any "RTN","SD53P491",167,0) .N SCL,DA,DR,CNT1 S SCL="",CNT1=0 F S SCL=$O(^SDWL(409.3,"SC",CL,SCL)) Q:SCL'>0 D "RTN","SD53P491",168,0) ..I '$D(^SDWL(409.3,SCL,0)) K ^SDWL(409.3,"SC",CL,SCL) Q "RTN","SD53P491",169,0) ..S DR="2////^S X=+STR",DIE="^SDWL(409.3,",DA=SCL "RTN","SD53P491",170,0) ..L +^SDWL(409.3,SCL):0 I '$T S CNT=CNT+1,SDX(CNT)="Entry locked; Run SD WAIT LIST CLEANUP later" W !?5,SDX(CNT),! Q "RTN","SD53P491",171,0) ..D ^DIE L -^SDWL(409.3,SCL) S CNT1=CNT1+1 "RTN","SD53P491",172,0) .I CNT1>0 W !,CNT1_" wait list entry(ies) for "_CLN_" clinic updated in SD WAIT LIST file #409.3." S CNT=CNT+1,SDX(CNT)="" "RTN","SD53P491",173,0) N DA I $$GET1^DIQ(409.32,SDWLSC_",",3,"I")="" I $$GET1^DIQ(409.32,SDWLSC_",",1,"I")'>0 D "RTN","SD53P491",174,0) .S DA=SDWLSC L +^SDWL(409.32,SDWLSC):0 I '$T S CNT=CNT+1,SDX(CNT)="Entry locked; Run SD WAIT LIST CLEANUP later" W !?5,SDX(CNT) Q "RTN","SD53P491",175,0) .S DR="1////^S X=DT;2////^S X=DUZ",DIE="^SDWL(409.32," ;enter activation date and user "RTN","SD53P491",176,0) .D ^DIE L -^SDWL(409.32,SDWLSC) "RTN","SD53P491",177,0) .S CNT=CNT+1,SDX(CNT)="EWL Clinic entry for "_CLN_" updated with today's activation date." "RTN","SD53P491",178,0) .W !,SDX(CNT) "RTN","SD53P491",179,0) .S CNT=CNT+1,SDX(CNT)="" "RTN","SD53P491",180,0) Q "RTN","SD53P491",181,0) MSGG(SDX) ;send message "RTN","SD53P491",182,0) N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ,DIFROM "RTN","SD53P491",183,0) S XMSUB="PATCH SD*5.3*491 POST-INSTALL: UPDATE FILES 409.3 and 409.32" "RTN","SD53P491",184,0) S XMY("G.SD EWL BACKGROUND UPDATE")="" "RTN","SD53P491",185,0) S XMY(DUZ)="" "RTN","SD53P491",186,0) S XMTEXT="SDX(" "RTN","SD53P491",187,0) S CNT=$O(SDX(""),-1) "RTN","SD53P491",188,0) S CNT=CNT+1,SDX(CNT)="" "RTN","SD53P491",189,0) S CNT=CNT+1,SDX(CNT)="SD WL CLINIC LOCATION file update is finished." "RTN","SD53P491",190,0) W !!,SDX(CNT) "RTN","SD53P491",191,0) S CNT=CNT+1,SDX(CNT)="Open EWL entries in the SD WAIT LIST file have also been updated." "RTN","SD53P491",192,0) W !,SDX(CNT) "RTN","SD53P491",193,0) S CNT=CNT+1,SDX(CNT)="If invalid/local Institution pointers were indicated above for" "RTN","SD53P491",194,0) W !!,SDX(CNT) "RTN","SD53P491",195,0) S CNT=CNT+1,SDX(CNT)="Hospital Location file #44, correct the DIVISION on those clinics" "RTN","SD53P491",196,0) W !,SDX(CNT) "RTN","SD53P491",197,0) S CNT=CNT+1,SDX(CNT)="and/or the INSTITUTION FILE POINTER of the Medical Center Division" "RTN","SD53P491",198,0) W !,SDX(CNT) "RTN","SD53P491",199,0) S CNT=CNT+1,SDX(CNT)="that the clinic points to, then run option SD WAIT LIST CLEANUP" "RTN","SD53P491",200,0) W !,SDX(CNT) "RTN","SD53P491",201,0) S CNT=CNT+1,SDX(CNT)="which will update institutions in EWL files 409.32 and 409.3." "RTN","SD53P491",202,0) W !,SDX(CNT) "RTN","SD53P491",203,0) S CNT=CNT+1,SDX(CNT)="" "RTN","SD53P491",204,0) W !,SDX(CNT) "RTN","SD53P491",205,0) S CNT=CNT+1,SDX(CNT)="NOTE: SD WAIT LIST CLEANUP must be run any time corrections are made to" "RTN","SD53P491",206,0) W !,SDX(CNT) "RTN","SD53P491",207,0) S CNT=CNT+1,SDX(CNT)="a Hospital Location file #44 entry's DIVISION or to an INSTITUTION FILE POINTER" "RTN","SD53P491",208,0) W !,SDX(CNT) "RTN","SD53P491",209,0) S CNT=CNT+1,SDX(CNT)="in the Medical Center division file #40.8." "RTN","SD53P491",210,0) W !,SDX(CNT) "RTN","SD53P491",211,0) D ^XMD "RTN","SDAL") 0^4^B25084907^B25089836 "RTN","SDAL",1,0) SDAL ;ALB/GRR,MJK - APPOINTMENT LIST ; 29 Jun 99 04:11PM ; Compiled August 20, 2007 14:24:59 "RTN","SDAL",2,0) ;;5.3;Scheduling;**37,46,106,171,177,80,266,491**;Aug 13, 1993;Build 53 "RTN","SDAL",3,0) EN W ! S SDEND=1 D ASK2^SDDIV G:Y<0 END "RTN","SDAL",4,0) W ! S VAUTNI=1 D NCOUNT^SDAL0 I SDCONC=U G END "RTN","SDAL",5,0) W ! D NCLINIC^SDAL0 G:Y<0 END "RTN","SDAL",6,0) RD1 W ! N %DT K DIC("S") S %DT("A")="For date: ",%DT="AEX" D ^%DT "RTN","SDAL",7,0) I (X["^")!(Y<0) K %,VAUTD,VAUTC,X,Y Q "RTN","SDAL",8,0) S SDD=Y "RTN","SDAL",9,0) N DIR S DIR(0)="Y",DIR("B")="NO" "RTN","SDAL",10,0) S DIR("A")="Include Primary Care assignment information in the output" "RTN","SDAL",11,0) W ! D ^DIR I $D(DTOUT)!$D(DUOUT) K SDD,VAUTC,VAUTD,X,Y Q "RTN","SDAL",12,0) W ! S SDPCMM=Y "RTN","SDAL",13,0) N K SDX,SDX1 R !,"Number of copies: 1// ",M:DTIME S:M="" M=1 "RTN","SDAL",14,0) I M["^" K M,SDD,VAUTC,VAUTD,X,Y Q "RTN","SDAL",15,0) I (M'?.N)!((M'>0)!($L(M)>3)) W !,"ENTER A WHOLE NUMBER TO SELECT THE # OF COPIES OF THE APPOINTMENT LIST THAT ARE NEEDED- (1-999)" G N "RTN","SDAL",16,0) S SDCOPY=M "RTN","SDAL",17,0) ; -- specify device "RTN","SDAL",18,0) W ! N %ZIS K IO("Q") S %ZIS="QMP" D ^%ZIS G END:POP "RTN","SDAL",19,0) S SDBC=$$BARQ(+IOST(0),IOM) I SDBC="^" G END "RTN","SDAL",20,0) I $D(IO("Q")) D QUE W:$D(ZTSK) " (Task#: ",ZTSK,")" G END "RTN","SDAL",21,0) ; "RTN","SDAL",22,0) START U IO N CNT,SDCLAR,SDCOUNT S (SDCOUNT,CNT)=0 "RTN","SDAL",23,0) ;SET UP A TEMP ARRAY -SDCLAR- WITH CLASSIFICATION ABBREVIATIONS "RTN","SDAL",24,0) F S CNT=$O(^SD(409.41,CNT)) Q:CNT'>0 D "RTN","SDAL",25,0) .S SDCLAR(CNT)=$P(^SD(409.41,CNT,0),U,7) "RTN","SDAL",26,0) S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL "RTN","SDAL",27,0) S SDASH="",$P(SDASH,"_",IOM+1)="" S SDBC=+$G(SDBC),SDCOPY=$S($D(SDCOPY):+SDCOPY,$D(M):+M,1:1) "RTN","SDAL",28,0) D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2) "RTN","SDAL",29,0) I SDBC S SDBC=$S(IOM<120:0,1:$$BARC^SDAMU(+IOST(0),.SDBCON,.SDBCOFF)) "RTN","SDAL",30,0) S (SDEND,SD1,PCNT)=0,Y=DT D D^DIQ S SDNT=Y,Y=SDD,X=Y D D^DIQ S SDPD=Y D DW^%DTC S SDPD=X_" "_SDPD "RTN","SDAL",31,0) ;if user has selected 'all' clinics, populate VAUTC with all uncancelled TYPE=C clinics from ^SC "RTN","SDAL",32,0) I VAUTC=1 S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:+SDIEN=0 D "RTN","SDAL",33,0) . I $P(^SC(SDIEN,0),"^",3)="C",$G(^SC(SDIEN,"ST",SDD,1))'["CANCELLED" D "RTN","SDAL",34,0) .. S SDNAME=$P(^SC(SDIEN,0),"^",1) I $G(SDNAME)]"" S VAUTC(SDNAME)=SDIEN "RTN","SDAL",35,0) ;-------------CALL TO SDAPI^SDAMA301 TO RETRIEVE APPT DATA------------------ "RTN","SDAL",36,0) K ^TMP($J,"SDAMA301") N SDARRAY,SDIEN,SDNAME,SDERR,SDCL,SDDFN,SDDT,SDRESULT "RTN","SDAL",37,0) S SDARRAY(1)=SDD_";"_SDD,SDARRAY(3)="I;R;NT",SDARRAY("FLDS")="4;6;7;8;10;19;20;21" "RTN","SDAL",38,0) ;if user has selected clinics, build clinic filter list "RTN","SDAL",39,0) I VAUTC'=1 D I $L(SDARRAY(2)) S SDARRAY(2)=$E(SDARRAY(2),1,$L(SDARRAY(2))-1) ;remove last ';' from end "RTN","SDAL",40,0) . S SD="" F S SD=$O(VAUTC(SD)) Q:SD']"" S SC=$G(VAUTC(SD)) I $G(SC)]"" S SDARRAY(2)=$G(SDARRAY(2))_SC_";" "RTN","SDAL",41,0) ;call SDAPI to retrieve appointment data "RTN","SDAL",42,0) S SDRESULT=$$SDAPI^SDAMA301(.SDARRAY) "RTN","SDAL",43,0) ;I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 D HED W !!,SDERR,! I $E(IOST,1,2)="C-" D OUT^SDUTL "RTN","SDAL",44,0) ;if error returned from SDAPI, display on report and quit "RTN","SDAL",45,0) I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 S SDPAGE=1 D HED W !!,SDERR,! D:$E(IOST,1,2)="C-" OUT^SDUTL D EXIT Q "RTN","SDAL",46,0) ;if appts returned from SDAPI, sort output by clinic, appt d/t, patient "RTN","SDAL",47,0) I SDRESULT>0 D "RTN","SDAL",48,0) . S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301",SDCL)) Q:'SDCL D "RTN","SDAL",49,0) .. S SDDFN=0 F S SDDFN=$O(^TMP($J,"SDAMA301",SDCL,SDDFN)) Q:'SDDFN D "RTN","SDAL",50,0) ... S SDDT=0 F S SDDT=$O(^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT)) Q:'SDDT D "RTN","SDAL",51,0) .... M ^TMP($J,"SDAMA301","S",SDCL,SDDT,SDDFN)=^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT) "RTN","SDAL",52,0) ;--------------------------------------------------------------------------- "RTN","SDAL",53,0) LOOPA ;S SD=0 F S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD']""!SDEND D CLIN "RTN","SDAL",54,0) ;if no error returned from SDAPI, start looping through clinics in VAUTC (sorted by name) "RTN","SDAL",55,0) I SDRESULT'<0 S SD=0 F S SD=$O(VAUTC(SD)) Q:SD']""!SDEND D CLIN "RTN","SDAL",56,0) G:SDEND END "RTN","SDAL",57,0) OVER ;S PCNT=PCNT+1 I PCNT0!SDEND I $D(^SC(SC,0)),$P(^(0),"^",3)="C" I $S(VAUTC:1,'$D(VAUTC(SD)):0,VAUTC(SD)=SC:1,1:0) D LOOP^SDAL0 "RTN","SDAL",69,0) ;process each clinic IEN from VAUTC array "RTN","SDAL",70,0) S (SDFL,SC)=0 S SC=$G(VAUTC(SD)) I $G(SC)>0,$D(^SC(SC,0)) D LOOP^SDAL0 "RTN","SDAL",71,0) Q "RTN","SDAL",72,0) ; "RTN","SDAL",73,0) BARQ(TTYPE,MARGIN) ; "RTN","SDAL",74,0) N ON,OFF,Y "RTN","SDAL",75,0) I MARGIN<120 S Y=0 G BARCQ "RTN","SDAL",76,0) I '$$BARC^SDAMU(.TTYPE,.ON,.OFF) S Y=0 G BARCQ "RTN","SDAL",77,0) S DIR(0)="Y",DIR("B")="NO",DIR("A")="SHOULD BARCODES BE PRINTED ON LIST(S)" "RTN","SDAL",78,0) D ^DIR K DIR S:$D(DIRUT) Y="^" "RTN","SDAL",79,0) BARCQ Q Y "RTN","SDAL",80,0) ; "RTN","SDAL",81,0) QUE ;Queue output "RTN","SDAL",82,0) N ZTDESC,ZTSAVE,ZTRTN "RTN","SDAL",83,0) K ZTSK,IO("Q") "RTN","SDAL",84,0) S ZTDESC="Appointment Lists",ZTRTN="START^SDAL" "RTN","SDAL",85,0) F X="VAUTD(","VAUTC(","SDCOPY","SDD","SDBC","VAUTD","VAUTC","SDCONC","SDPCMM" S ZTSAVE(X)="" "RTN","SDAL",86,0) D ^%ZTLOAD "RTN","SDAL",87,0) Q "RTN","SDAL",88,0) ; "RTN","SDAL",89,0) STOP ;Check for stop task request "RTN","SDAL",90,0) S:$D(ZTQUEUED) (SDEND,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q "RTN","SDAL",91,0) ; "RTN","SDAL",92,0) HED ;Print report header "RTN","SDAL",93,0) I SD1,$E(IOST)="C" D OUT^SDUTL Q:SDEND "RTN","SDAL",94,0) D STOP Q:SDEND "RTN","SDAL",95,0) S SDCOUNT=SDCOUNT+1,SD1=1 "RTN","SDAL",96,0) W:SDCOUNT>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) "RTN","SDAL",97,0) W:SC "Appointments for ",$P(^SC(SC,0),"^",1)," clinic on ",SDPD "RTN","SDAL",98,0) W:'SC "Appointments for ",SDPD "RTN","SDAL",99,0) W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,! "RTN","SDAL",100,0) W !," Appt.",?11,"Patient Name",?44,"SSN",?53,"Lab",?62,"X-Ray",?73,"EKG" "RTN","SDAL",101,0) ;W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" "RTN","SDAL",102,0) W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" "RTN","SDAL",103,0) W !,SDASH S SDPAGE=SDPAGE+1 "RTN","SDAL",104,0) D:SDBC PAINT(SC,SDD) "RTN","SDAL",105,0) Q "RTN","SDAL",106,0) ; "RTN","SDAL",107,0) PAINT(CLINIC,DATE) ; -- paint header barcodes "RTN","SDAL",108,0) ; input: CLINIC := clinic ifn "RTN","SDAL",109,0) ; DATE := appt date only "RTN","SDAL",110,0) ; "RTN","SDAL",111,0) W !?10,"Date",?45,"Clinic#",?85,"No",?110,"Yes",! "RTN","SDAL",112,0) D BARC(10,$E(DATE,4,7)_$E(DATE,2,3)) "RTN","SDAL",113,0) D BARC(45,"%"_CLINIC_"$") "RTN","SDAL",114,0) D BARC(85,"N"),BARC(110,"Y") "RTN","SDAL",115,0) W !!!!,SDASH "RTN","SDAL",116,0) Q "RTN","SDAL",117,0) ; "RTN","SDAL",118,0) BARC(TAB,X) ; --print barcode "RTN","SDAL",119,0) ; input: TAB := tab position "RTN","SDAL",120,0) ; X := string to print "RTN","SDAL",121,0) ; "RTN","SDAL",122,0) W *13,?TAB W @SDBCON,X,@SDBCOFF "RTN","SDAL",123,0) Q "RTN","SDAL",124,0) ; "RTN","SDAM10") 0^5^B8926237^B8130933 "RTN","SDAM10",1,0) SDAM10 ;MJK/ALB - Appt Mgt (Patient cont.); 3/18/05 3:51pm ; Compiled March 31, 2008 16:38:47 "RTN","SDAM10",2,0) ;;5.3;Scheduling;**189,258,403,478,491**;Aug 13, 1993;Build 53 "RTN","SDAM10",3,0) ; "RTN","SDAM10",4,0) HDR ; -- list screen header "RTN","SDAM10",5,0) ; input: SDFN := ifn of pat "RTN","SDAM10",6,0) ; output: VALMHDR() := hdr array "RTN","SDAM10",7,0) ; "RTN","SDAM10",8,0) N VAERR,VA,X "RTN","SDAM10",9,0) S DFN=SDFN D PID^VADPT "RTN","SDAM10",10,0) S VALMHDR(1)=$E($P("Patient: "_$G(^DPT(SDFN,0)),U),1,46)_" ("_VA("BID")_")" ;for proper display of patient name for SD*5.3*189 "RTN","SDAM10",11,0) S X=$P($$FMT^SDUTL2(SDFN),U,2),X=$S(X["GMT":X,X]"":"MT: "_X,1:"") "RTN","SDAM10",12,0) S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),47,15) ;repositioned header to display clinic or patient name properly for SD*5.3*189 "RTN","SDAM10",13,0) S X=$S($D(^DPT(SDFN,.1)):"Ward: "_^(.1),1:"Outpatient") "RTN","SDAM10",14,0) S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$L(X),$L(X)) "RTN","SDAM10",15,0) Q "RTN","SDAM10",16,0) ; "RTN","SDAM10",17,0) PAT ; -- change pat "RTN","SDAM10",18,0) K TMP ;SD/478 "RTN","SDAM10",19,0) D FULL^VALM1 S VALMBCK="R" "RTN","SDAM10",20,0) K X I $D(XQORNOD(0)) S X=$P($P(XQORNOD(0),U,4),"=",2) "RTN","SDAM10",21,0) I $D(X),X="" R !!,"Select Patient: ",X:DTIME "RTN","SDAM10",22,0) D RT^SDAMEX S DIC="^DPT(",DIC(0)="EMQ" D ^DIC K DIC G PAT:X["?" "RTN","SDAM10",23,0) PAT1 S %=1 I Y>0 W !," ...OK" D YN^DICN I %=0 W " Answer with 'Yes' or 'No'" G PAT1 "RTN","SDAM10",24,0) I %'=1 S Y=-1 "RTN","SDAM10",25,0) I Y<0 D G PATQ "RTN","SDAM10",26,0) .I $G(DFN)>0,SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been changed." "RTN","SDAM10",27,0) .I $G(DFN)'>0,SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been selected." "RTN","SDAM10",28,0) .I SDAMTYP="C" S VALMSG=$C(7)_"View of clinic remains in affect." "RTN","SDAM10",29,0) .W !!,$G(VALMSG) H 1 "RTN","SDAM10",30,0) I SDAMTYP'="P" D CHGCAP^VALM("NAME","Clinic") S SDAMTYP="P" "RTN","SDAM10",31,0) S (DFN,SDFN)=+Y K SDCLN,VADM D DEM^VADPT D BLD^SDAM1 ;SD/491 "RTN","SDAM10",32,0) PATQ Q "RTN","SDAM10",33,0) ; "RTN","SDAM10",34,0) INIT ; -- init bld vars "RTN","SDAM10",35,0) K VALMHDR,SDDA,^TMP("SDAMIDX",$J) "RTN","SDAM10",36,0) D CLEAN^VALM10 "RTN","SDAM10",37,0) S VALMBG=1,(VALMCNT,SDACNT)=0,BL="",$P(BL," ",30)="",SDMAX=100 "RTN","SDAM10",38,0) S SDAMDD=$P(^DD(2.98,3,0),U,3) "RTN","SDAM10",39,0) ; -- format vars |- column -| |- width -| "RTN","SDAM10",40,0) S X=VALMDDF("APPT#"),AC=$P(X,U,2),AW=$P(X,U,3) ; A for appt "RTN","SDAM10",41,0) S X=VALMDDF("DATE"),XC=$P(X,U,2),XW=$P(X,U,3) ; X for date "RTN","SDAM10",42,0) S X=VALMDDF("NAME"),NC=$P(X,U,2),NW=$P(X,U,3) ; N for name "RTN","SDAM10",43,0) S X=VALMDDF("STAT"),SC=$P(X,U,2),SW=$P(X,U,3) ; S for status "RTN","SDAM10",44,0) S X=VALMDDF("TIME"),TC=$P(X,U,2),TW=$P(X,U,3) ; T for time "RTN","SDAM10",45,0) S (CC,CW)="",X=$G(VALMDDF("CONSULT")) I X'="" S CC=$P(X,U,2),CW=$P(X,U,3) ; C for Consult ;SD/478 "RTN","SDAM10",46,0) Q "RTN","SDAM10",47,0) ; "RTN","SDAM10",48,0) LARGE ; -- too large note "RTN","SDAM10",49,0) W !!?5,*7,"Note: Ending Date was changed to '",$$FDATE^VALM1(SDEND),"' because" "RTN","SDAM10",50,0) W !?11,"too many appointments met date range criteria." D PAUSE^VALM1 "RTN","SDAM10",51,0) Q "RTN","SDAM10",52,0) ; "RTN","SDAM10",53,0) NUL ; -- set nul message "RTN","SDAM10",54,0) I '$O(^TMP("SDAM",$J,0)) D SET^SDAM1(" "),SET^SDAM1(" No appointments meet criteria.") "RTN","SDAM10",55,0) Q "RTN","SDAM10",56,0) ; "RTN","SDAMVSC") 0^6^B8458150^B6558440 "RTN","SDAMVSC",1,0) SDAMVSC ;;OIFO-BAY PINES/TEH - Appt Event Driver Utilities-Validate SC Appt type ; 12/1/91 [ 09/19/96 1:39 PM ] ; Compiled August 20, 2007 14:28:26 "RTN","SDAMVSC",2,0) ;;5.3;Scheduling;**394,417,491**;Aug 13, 1993;Build 53 "RTN","SDAMVSC",3,0) ; "RTN","SDAMVSC",4,0) ; "RTN","SDAMVSC",5,0) ;*************************************************************************************************************************** "RTN","SDAMVSC",6,0) ; "RTN","SDAMVSC",7,0) ; ***** NOTE ***** "RTN","SDAMVSC",8,0) ; "RTN","SDAMVSC",9,0) ;This software was created to be used with the SCHEDULING V5.3 appointment management package. The SRA API (SDAMA301) "RTN","SDAMVSC",10,0) ;was employed to retrieve data from the PATIENT APPOINTMENT file (2.98) due inpart to VA Fileman non-compliance. "RTN","SDAMVSC",11,0) ; "RTN","SDAMVSC",12,0) ;DBIA #4433 SUBSCRIPTION "RTN","SDAMVSC",13,0) ; "RTN","SDAMVSC",14,0) ; "RTN","SDAMVSC",15,0) ;Entry Point EN. This routine requires the OUTPATIENT ENOUNTER IEN (variable SDOE) "RTN","SDAMVSC",16,0) ; "RTN","SDAMVSC",17,0) ;GLOBALS: ^SCE(IEN,0) (#.1) APPOINTMENT TYPE [10P:409.1] "RTN","SDAMVSC",18,0) ; ^DPT(IEN,"S",DATE,0) ^ (#9.5) APPOINTMENT TYPE [16P:409.1] "RTN","SDAMVSC",19,0) ; ^SD(409.41,0)=OUTPATIENT CLASSIFCATION TYPE "Was treatment for SC Condition? " QUESTION FOR CHECKOUT. "RTN","SDAMVSC",20,0) ; "RTN","SDAMVSC",21,0) ;PROTOCOLS: This routine is called from the SDAM APPOINTMENT EVENTS. "RTN","SDAMVSC",22,0) ; "RTN","SDAMVSC",23,0) ;This validates that both the OUTPATIENT ENCOUNTER and the PATIENT SCHEDULING NODES for APPOINTMENT TYPE are (pointer to "RTN","SDAMVSC",24,0) ;409.1 APPOINTMENT TYPE) are set to the "SERVICE CONNECTED" appointment type when the response to the CLASSIFICATION TYPE "RTN","SDAMVSC",25,0) ;"Was treatment for SC Condition?" question is answered "YES". If the question is answered "NO" and the APPOINTMENT TYPE "RTN","SDAMVSC",26,0) ;is SERVICE CONNECTED, then the APPOINTMENT TYPE is reverted to REGULAR. "RTN","SDAMVSC",27,0) ; "RTN","SDAMVSC",28,0) ; "RTN","SDAMVSC",29,0) ;**************************************************************************************************************************** "RTN","SDAMVSC",30,0) Q "RTN","SDAMVSC",31,0) EN ;Entry Point "RTN","SDAMVSC",32,0) Q:'$G(SDOE) "RTN","SDAMVSC",33,0) N SDN,SDVSCL,SDVSTD,SDAPDF,SDDPTYP,SDOED,SDVSTD,SDVDPTD,SDVSCD,SDSCV,SDAPPTY,SDAPDT,SDDFN,SDVSTD,SDIENS,SDARRAY,SDAPDF "RTN","SDAMVSC",34,0) S SDOED=$G(^SCE(SDOE,0)) Q:SDOED="" "RTN","SDAMVSC",35,0) S SDDFN=$P(SDOED,U,2),SDAPDT=$P(SDOED,U) "RTN","SDAMVSC",36,0) ;GET APPOINTMENT FROM EVENT OUTPUT ARRAY "RTN","SDAMVSC",37,0) I $G(^TMP("SDAMEVT",$J,"AFTER","DPT")) S SDAPDPT=$P($G(^TMP("SDAMEVT",$J,"AFTER","DPT")),"^",16) "RTN","SDAMVSC",38,0) E S SDAPDPT=$P(SDOED,"^",10) ;APP TYPE "RTN","SDAMVSC",39,0) S SDVSCL=$P(SDOED,U,4) "RTN","SDAMVSC",40,0) S SDVSTD=$P(SDOED,U,5) "RTN","SDAMVSC",41,0) Q:'SDVSTD ; ticket #194210 ; do not proceed if no pointer to a visit "RTN","SDAMVSC",42,0) Q:'$D(^AUPNVSIT(SDVSTD,800)) "RTN","SDAMVSC",43,0) S SDSCV=+$$GET1^DIQ(9000010,SDVSTD_",",80001,"I") ;SC flag in Visit file "RTN","SDAMVSC",44,0) S SDAPDF=$$GET1^DIQ(44,SDVSCL_",",2507,"I") ;default appt type "RTN","SDAMVSC",45,0) ;find if credit stop secondary visit exists. "RTN","SDAMVSC",46,0) N SDVSTDS,SDOE1 S SDOE1="" S SDVSTDS=$O(^AUPNVSIT("AD",SDVSTD,"")) "RTN","SDAMVSC",47,0) I SDVSTDS>0 S SDOE1=$O(^SCE("AVSIT",SDVSTDS,"")) "RTN","SDAMVSC",48,0) I SDSCV I SDAPDPT'=11 S SDAPDPT=11 D APPT F SDE=SDOE,SDOE1 I SDE>0 D SCE(SDE) "RTN","SDAMVSC",49,0) I 'SDSCV I SDAPDPT=11 D D APPT F SDE=SDOE,SDOE1 I SDE>0 D SCE(SDE) "RTN","SDAMVSC",50,0) . I SDAPDF'="" S SDAPDPT=SDAPDF ; set to default if exists for this clinic "RTN","SDAMVSC",51,0) . E S SDAPDPT=9 ; set to regular "RTN","SDAMVSC",52,0) Q "RTN","SDAMVSC",53,0) SCE(SDE) ;Set FDA for SCE(ien,0) OUTPATIENT ENCOUNTER "RTN","SDAMVSC",54,0) S SDIENS=SDE_"," K ^TMP("SDAMSCE",$J) "RTN","SDAMVSC",55,0) D FDA^DILF(409.68,SDIENS,.1,,SDAPDPT,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") "RTN","SDAMVSC",56,0) I $D(^TMP("SDAMSCE",$J,"DIERR")) D Q "RTN","SDAMVSC",57,0) .W !,"Processing Error ",^TMP("SDAMSCE",$J,"DIERR",1) Q "RTN","SDAMVSC",58,0) D FILE^DIE(,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") "RTN","SDAMVSC",59,0) Q "RTN","SDAMVSC",60,0) APPT ;quit if clinic in event doesn't match clinic in ^DPT "RTN","SDAMVSC",61,0) ;set up app type in DPT "RTN","SDAMVSC",62,0) I +$G(^TMP("SDAMEVT",$J,"AFTER","DPT"))'=+$G(^DPT(SDDFN,"S",SDAPDT,0)) Q "RTN","SDAMVSC",63,0) I $D(^DPT(SDDFN,"S",SDAPDT,0)) S $P(^DPT(SDDFN,"S",SDAPDT,0),U,16)=SDAPDPT "RTN","SDAMVSC",64,0) END Q "RTN","SDRPA00") 0^7^B83224590^B79872528 "RTN","SDRPA00",1,0) SDRPA00 ;BP-OIFO/OWAIN,ESW - Patient Appointment Information Transmission ; 11/2/04 11:09am ; 2/24/08 11:25am "RTN","SDRPA00",2,0) ;;5.3;Scheduling;**290,333,349,376,491**;Aug 13,1993;Build 53 "RTN","SDRPA00",3,0) ;SD/491 - calling SRPA03 instead of SDRPA04 (dupl) "RTN","SDRPA00",4,0) Q "RTN","SDRPA00",5,0) EN ;manual entry "RTN","SDRPA00",6,0) N SDI,Y,ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,RUNID,REC "RTN","SDRPA00",7,0) I '$$RUNCK^SDRPA02() W !,"You attempted to start PAIT outside the authorized transmission dates.",!,"Job has been terminated.",! Q "RTN","SDRPA00",8,0) S RUNID=$O(^SDWL(409.6,":"),-1) "RTN","SDRPA00",9,0) I RUNID S ZTSK=$P(^SDWL(409.6,RUNID,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"A task is currently active." Q "RTN","SDRPA00",10,0) K ZTSK N SDCON S SDCON=1 "RTN","SDRPA00",11,0) S %DT("A")="Queue to run: " "RTN","SDRPA00",12,0) S %DT="AEFXR" W ! D ^%DT S DT=Y D:Y'=-1 Q:'SDCON "RTN","SDRPA00",13,0) .S ZTDTH=Y,ZTRTN="START^SDRPA00",ZTIO="" "RTN","SDRPA00",14,0) .S ZTDESC="PAIT" "RTN","SDRPA00",15,0) .I RUNID I $P(^SDWL(409.6,RUNID,0),U,7)="" S SDCON=0 D "RTN","SDRPA00",16,0) ..W !,"The previous run errored out, not repaired!",!,"Please address a problem and use SD-PAIT REPAIR to fix the run." "RTN","SDRPA00",17,0) .Q:'SDCON "RTN","SDRPA00",18,0) .F SDI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK) "RTN","SDRPA00",19,0) .I $G(ZTSK) W !,"Task # "_ZTSK_" queued!" "RTN","SDRPA00",20,0) I '$G(ZTSK) W !!,"Task not queued, check Taskman",! Q "RTN","SDRPA00",21,0) W !!,"Task number: ",ZTSK,! "RTN","SDRPA00",22,0) Q "RTN","SDRPA00",23,0) START ;Tasked entry "RTN","SDRPA00",24,0) N SDOUT,DFN,DFNEND,SDCNT,SDCNT0,RUNID,RUNDT,SDPREV,FIRST,SDDAM,TODAY,SD6A,SD8A,SD68,RUNIDP,SDPR,ZTSKN "RTN","SDRPA00",25,0) I '$$RUNCK^SDRPA02() Q ;check scheduling "RTN","SDRPA00",26,0) I $G(ZTSK)="" D Q "RTN","SDRPA00",27,0) . W !,"NOT AN INTERACTIVE OPTION...schedule through TaskMan",!! "RTN","SDRPA00",28,0) S ZTSKN=ZTSK "RTN","SDRPA00",29,0) S SDPR=$O(^SDWL(409.6,":"),-1) ;previous run "RTN","SDRPA00",30,0) I SDPR N SD1 S SD1=0 D Q:SD1 ;finish if task is still running "RTN","SDRPA00",31,0) .I $P(^SDWL(409.6,SDPR,0),U,7)'="" Q ; previous task finished "RTN","SDRPA00",32,0) .N ZTSK "RTN","SDRPA00",33,0) .S ZTSK=$P(^SDWL(409.6,SDPR,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) S SD1=1 "RTN","SDRPA00",34,0) .;send message "RTN","SDRPA00",35,0) .N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ "RTN","SDRPA00",36,0) .S XMSUB="PAIT BACKGROUND JOB" "RTN","SDRPA00",37,0) .S XMY("G.SD-PAIT")="" "RTN","SDRPA00",38,0) .S XMTEXT="SDAMX(" "RTN","SDRPA00",39,0) .S XMDUZ="POSTMASTER" "RTN","SDRPA00",40,0) .S SDAMX(1)="The PAIT requested task has been terminated." "RTN","SDRPA00",41,0) .S SDAMX(2)="The previous task #: "_ZTSK_" run #: "_SDPR_" has not been completed." "RTN","SDRPA00",42,0) .I SD1=1 S SDAMX(3)="It is still running.",SDAMX(4)="" "RTN","SDRPA00",43,0) .E S SD1=2 D "RTN","SDRPA00",44,0) ..S SDAMX(3)="The previous run errored out, not repaired!" "RTN","SDRPA00",45,0) ..S SDAMX(4)="Address a problem and use option SD-PAIT REPAIR to fix the run." "RTN","SDRPA00",46,0) .D ^XMD "RTN","SDRPA00",47,0) S DIC=409.6,DIC(0)="X" "RTN","SDRPA00",48,0) D NOW^%DTC S TODAY=X "RTN","SDRPA00",49,0) K DO D FILE^DICN "RTN","SDRPA00",50,0) S DA=+Y,DIE=DIC,DR="1///"_ZTSK D ^DIE "RTN","SDRPA00",51,0) ;send START message "RTN","SDRPA00",52,0) D STMES "RTN","SDRPA00",53,0) S (SDOUT,SDCNT)=0 "RTN","SDRPA00",54,0) K ^TMP("SDDPT",$J) "RTN","SDRPA00",55,0) N CRUNID S CRUNID=$O(^SDWL(409.6,"AD",ZTSK,"")) "RTN","SDRPA00",56,0) S RUNDT=$P(^SDWL(409.6,CRUNID,0),"^") "RTN","SDRPA00",57,0) I SDPR=0 S SDPREV=3020831,FIRST=1 ;first run "RTN","SDRPA00",58,0) E S SDPREV=$P(^SDWL(409.6,SDPR,0),U,4),FIRST=0 ; "RTN","SDRPA00",59,0) N SDFIN,SDPEN,SDF,SDTR S (RUNID,SDFIN,SDPEN,SDTR,SDF)=0 "RTN","SDRPA00",60,0) S SDDAM=SDPREV ;creation date "RTN","SDRPA00",61,0) D NOW^%DTC S TODAY=X "RTN","SDRPA00",62,0) F S SDDAM=$O(^DPT("ASADM",SDDAM)) Q:SDDAM="" Q:SDDAM=TODAY!SDOUT D "RTN","SDRPA00",63,0) .N DFN S DFN=0 "RTN","SDRPA00",64,0) .F S DFN=$O(^DPT("ASADM",SDDAM,DFN)) Q:+DFN'=DFN!SDOUT D "RTN","SDRPA00",65,0) ..N SDADT S SDADT=0 ;appt date/time "RTN","SDRPA00",66,0) ..S SDADT=0 "RTN","SDRPA00",67,0) ..F S SDADT=$O(^DPT("ASADM",SDDAM,DFN,SDADT)) Q:+SDADT'=SDADT!SDOUT D "RTN","SDRPA00",68,0) ...I SDADT'>3030000 Q ;only appointment scheduled for 2003 and later; sd/491 "RTN","SDRPA00",69,0) ...I SDDAM'=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") Q ;compare creation dates "RTN","SDRPA00",70,0) ...; Check for 'stop task' request "RTN","SDRPA00",71,0) ...S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT D N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q "RTN","SDRPA00",72,0) ....N DA,DIE,DR,SDD,SDLAST D "RTN","SDRPA00",73,0) ....S SDLAST=$O(^SDWL(409.6,CRUNID,1,"B"),-1) S SDD=$P(^SDWL(409.6,CRUNID,1,SDLAST,0),U,7)-1 "RTN","SDRPA00",74,0) ....S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE "RTN","SDRPA00",75,0) ...N SDCL,SDSTAT,SDSTTY "RTN","SDRPA00",76,0) ...S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") "RTN","SDRPA00",77,0) ...Q:SDCL="" ; If this happens, there's something wrong. "RTN","SDRPA00",78,0) ...; "RTN","SDRPA00",79,0) ...; Check status. "RTN","SDRPA00",80,0) ...; Appoinment made only before Sep 1, 2003 "RTN","SDRPA00",81,0) ...; If it is not the first run, send but don't create a pending file "RTN","SDRPA00",82,0) ...; Otherwise add to pending file. "RTN","SDRPA00",83,0) ...D NOW^%DTC N STODAY S STODAY=X "RTN","SDRPA00",84,0) ...S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,STODAY,1) "RTN","SDRPA00",85,0) ...I $P(SDSTAT,"^")=0 Q "RTN","SDRPA00",86,0) ...N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL ;assign a new clinic if from matching non count with encounter "RTN","SDRPA00",87,0) ...S SDSTTY=$P(SDSTAT,U,2),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) "RTN","SDRPA00",88,0) ...I SDSTTY="F" Q:'$$GT90DAYS(SDDAM,3030831) ; pending and final from 09/01/2003, previously 90 days "RTN","SDRPA00",89,0) ...I SDSTTY="F",SD6A="NM",SD8A="NC" Q ; skip non-count if not matching count and scheduled date already expired "RTN","SDRPA00",90,0) ...N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U) "RTN","SDRPA00",91,0) ...N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. "RTN","SDRPA00",92,0) ...N DIC,DA,X,SDRET D "RTN","SDRPA00",93,0) ....N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") "RTN","SDRPA00",94,0) ....S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" "RTN","SDRPA00",95,0) ....K DO S X=DFN D FILE^DICN "RTN","SDRPA00",96,0) ....S DA=+Y,DIE=DIC,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE "RTN","SDRPA00",97,0) ....Q "RTN","SDRPA00",98,0) ...D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) "RTN","SDRPA00",99,0) ...S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) "RTN","SDRPA00",100,0) ...S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 "RTN","SDRPA00",101,0) Q:SDOUT "RTN","SDRPA00",102,0) N SDD S SDD=$O(^DPT("ASADM",TODAY),-1) ;enter the last scanned day "RTN","SDRPA00",103,0) S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE "RTN","SDRPA00",104,0) ; scan the previous runs "RTN","SDRPA00",105,0) S RUNID=0 "RTN","SDRPA00",106,0) F S RUNID=$O(^SDWL(409.6,RUNID)) Q:+RUNID=CRUNID!SDOUT D "RTN","SDRPA00",107,0) .N APPTID,SDADT,REC "RTN","SDRPA00",108,0) .S APPTID=0 "RTN","SDRPA00",109,0) .;scanning only appointments that were sent as 'pending' "RTN","SDRPA00",110,0) .F S APPTID=$O(^SDWL(409.6,"AE","Y",RUNID,APPTID)) Q:APPTID=""!SDOUT S REC=$G(^SDWL(409.6,RUNID,1,APPTID,0)) D "RTN","SDRPA00",111,0) ..IF REC="" K ^SDWL(409.6,"AE","Y",RUNID,APPTID) Q ;anticipate "RTN","SDRPA00",112,0) ..S DFN=$P(REC,"^"),SDADT=$P(REC,"^",2) "RTN","SDRPA00",113,0) ..;evaluate SDADT - appt date/time for possible removal from sending "RTN","SDRPA00",114,0) ..I SDADT'>3030000 N DIK S DIK="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID,DA=APPTID D ^DIK ;delete entry; not to be sent; sd/491 "RTN","SDRPA00",115,0) ..; Check for 'stop task' "RTN","SDRPA00",116,0) ..S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q ; "RTN","SDRPA00",117,0) ..N SDCL,SDCLO,SDCE,SDSTAT,SDREJ,SDDAM,SDDAMO "RTN","SDRPA00",118,0) ..S SDCLO=$P(REC,"^",10) "RTN","SDRPA00",119,0) ..S SDREJ=$P(REC,"^",8),SDDAMO=$P(REC,"^",7) ;esw "RTN","SDRPA00",120,0) ..I SDDAMO="" D "RTN","SDRPA00",121,0) ...N SDD S SDD=9999999 F S SDD=$O(^DPT("ASADM",SDD),-1) Q:SDD'>0 I $D(^DPT("ASADM",SDD,DFN,SDADT)) S SDDAMO=SDD Q "RTN","SDRPA00",122,0) ..Q:SDDAMO="" ;cannot determine what was original creation date "RTN","SDRPA00",123,0) ..;evaluate if the same creation date "RTN","SDRPA00",124,0) ..S SDDAM=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") "RTN","SDRPA00",125,0) ..S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") "RTN","SDRPA00",126,0) ..Q:SDCL="" ; "RTN","SDRPA00",127,0) ..I SDCLO="" S SDCLO=SDCL "RTN","SDRPA00",128,0) ..I SDDAM'?7N!(SDDAM'>3020831) S SDDAM=SDDAMO ; need to finalize the previously sent "RTN","SDRPA00",129,0) ..; Check status. If it is a termination, continue. "RTN","SDRPA00",130,0) ..Q:$D(^TMP("SDDPT",$J,DFN,SDADT)) ; overridden to be process next time "RTN","SDRPA00",131,0) ..;anothercross reference entry will be created; do not need to quit "RTN","SDRPA00",132,0) ..;Q:$D(^SDWL(409.6,"AC",DFN,SDADT,+$G(CRUNID))) ;see above "RTN","SDRPA00",133,0) ..S SDSTAT="" "RTN","SDRPA00",134,0) ..I SDDAM'=SDDAMO!(SDCL'=SDCLO) D "RTN","SDRPA00",135,0) ...; create CT status; the current SDADT has different creation date "RTN","SDRPA00",136,0) ...S SDSTAT="S15"_U_"F"_U_"CT"_U_U_U_U_U S SDDAM=SDDAMO,SDCL=SDCLO "RTN","SDRPA00",137,0) ..I SDSTAT="" D NOW^%DTC N SDTODAY S SDTODAY=X S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,SDTODAY,0) "RTN","SDRPA00",138,0) ..I $P(SDSTAT,"^")=0 Q "RTN","SDRPA00",139,0) ..N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) "RTN","SDRPA00",140,0) ..N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL "RTN","SDRPA00",141,0) ..S SDSTTY=$P(SDSTAT,U,2) "RTN","SDRPA00",142,0) ..I SDSTTY="P"&(SDREJ="") Q ;do not send in pending status if not rejected ;esw "RTN","SDRPA00",143,0) ..N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. "RTN","SDRPA00",144,0) ..N DIC,DA,X D "RTN","SDRPA00",145,0) ...N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") "RTN","SDRPA00",146,0) ...S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" "RTN","SDRPA00",147,0) ...K DO S X=DFN D FILE^DICN "RTN","SDRPA00",148,0) ...S DA=+Y,DIE=DIC,DA=+Y,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE "RTN","SDRPA00",149,0) ..N DIC,DA D "RTN","SDRPA00",150,0) ...; not rejected can be sent only as 'S'- sent as final "RTN","SDRPA00",151,0) ...N SDRET S SDRET=$S(SDREJ'="":"R",1:"S") ; indicates that it was: R - sent as rejected, S - sent as final "RTN","SDRPA00",152,0) ...S DIC="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID "RTN","SDRPA00",153,0) ...S DA=APPTID,DIE=DIC,DR="4////"_SDRET D ^DIE "RTN","SDRPA00",154,0) ..D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) "RTN","SDRPA00",155,0) ..S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) "RTN","SDRPA00",156,0) ..S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 "RTN","SDRPA00",157,0) .Q "RTN","SDRPA00",158,0) Q:SDOUT "RTN","SDRPA00",159,0) I $O(^TMP("SDDPT",$J,"")) D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) "RTN","SDRPA00",160,0) K ^TMP("SDDPT",$J) "RTN","SDRPA00",161,0) D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN) "RTN","SDRPA00",162,0) Q "RTN","SDRPA00",163,0) STMES ;generate start message "RTN","SDRPA00",164,0) N SDS,SD870,SD87 "RTN","SDRPA00",165,0) S SD870=$O(^HLCS(870,"B","SD-PAIT","")) "RTN","SDRPA00",166,0) N ARRAY D GETS^DIQ(870,SD870_",",4,"I","ARRAY") "RTN","SDRPA00",167,0) N SD87 S SD87=SD870_"," "RTN","SDRPA00",168,0) S SDSTAT=ARRAY(870,SD87,4,"I") "RTN","SDRPA00",169,0) D NOW^%DTC "RTN","SDRPA00",170,0) N SDDT,SDST S SDDT=% "RTN","SDRPA00",171,0) S SDST=$P($$SITE^VASITE(),"^",3) "RTN","SDRPA00",172,0) N SDAMX,XMSUB,CMY,XMTEXT,XMDUZ "RTN","SDRPA00",173,0) S XMSUB=$G(SDST)_" - PAIT START JOB" "RTN","SDRPA00",174,0) S XMY("G.SD-PAIT")="" "RTN","SDRPA00",175,0) S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" "RTN","SDRPA00",176,0) S XMTEXT="SDAMX(" "RTN","SDRPA00",177,0) S XMDUZ="POSTMASTER" "RTN","SDRPA00",178,0) S SDAMX(1)="The PAIT job has started - TASK #: "_ZTSK "RTN","SDRPA00",179,0) S SDAMX(2)="Site Started SD-PAIT status Task #" "RTN","SDRPA00",180,0) S SDAMX(3)=SDST_" |"_SDDT_" |"_SDSTAT_" |"_ZTSK "RTN","SDRPA00",181,0) ; "RTN","SDRPA00",182,0) I SDSTAT="Shutdown" S XMY("VHACIONHD@MED.VA.GOV")="" D "RTN","SDRPA00",183,0) .S SDAMX(4)=" Please start a REMEDY ticket for station "_SDST "RTN","SDRPA00",184,0) .S SDAMX(5)="SD-PAIT Logical Link has to be started." "RTN","SDRPA00",185,0) .S SDAMX(6)="Refer the ticket to Scheduling PAIT." "RTN","SDRPA00",186,0) .S SDAMX(7)="" "RTN","SDRPA00",187,0) D ^XMD "RTN","SDRPA00",188,0) Q "RTN","SDRPA00",189,0) ; "RTN","SDRPA00",190,0) GT90DAYS(X1,X2) ; Date is older than Sep 1st 2003, see specs. "RTN","SDRPA00",191,0) ; X1 - creation date. More efficient to have it set at the top instead of every time this subroutine is called. "RTN","SDRPA00",192,0) ; X2 - comparison date, now sent as Sep 1 2003, both in Vista format cyymmdd "RTN","SDRPA00",193,0) D ^%DTC "RTN","SDRPA00",194,0) Q X>0 ; "RTN","SDRPA00",195,0) STAT(SDSTTY,SDFF,SDFIN,SDPEN,SDF) ;summarize pending and finals "RTN","SDRPA00",196,0) I SDSTTY="F" S SDFIN=SDFIN+1 Q "RTN","SDRPA00",197,0) I SDSTTY="P" S SDPEN=SDPEN+1 I SDFF="F" S SDF=SDF+1 "RTN","SDRPA00",198,0) Q "RTN","SDRPA03") 1^16^^B31121600 "RTN","SDRPA04") 0^8^B41493577^B37937936 "RTN","SDRPA04",1,0) SDRPA04 ;BP-OIFO/ESW - SDRPA00 continuation PAIT - REPAIR ; 11/2/04 11:47am ; 5/31/07 5:29pm "RTN","SDRPA04",2,0) ;;5.3;Scheduling;**376,491**;Aug 13, 1993;Build 53 "RTN","SDRPA04",3,0) ;SD/491 - not to error out while repairing with acks having received "RTN","SDRPA04",4,0) Q "RTN","SDRPA04",5,0) MSGT(CRUNID,SDPEN,SDFIN,SDTOT,SDSTOP) ;create completion messages "RTN","SDRPA04",6,0) ;CRUNID - current run number "RTN","SDRPA04",7,0) ;SDPEN - pendings "RTN","SDRPA04",8,0) ;SDFIN - finals "RTN","SDRPA04",9,0) ;SDTOT - total "RTN","SDRPA04",10,0) ;SDSTOP - task stop flag "RTN","SDRPA04",11,0) N SDB,SDTRF "RTN","SDRPA04",12,0) I '$D(SDTOT) S SDTOT=SDPEN+SDFIN "RTN","SDRPA04",13,0) N SFF S SFF=0 "RTN","SDRPA04",14,0) I +SDTOT=0 S (SDPEN,SDFIN)=0,SFF=1 "RTN","SDRPA04",15,0) I '$D(SDPEN),'$D(SDFIN) S (SDPEN,SDFIN)="undetermined",SFF=1 "RTN","SDRPA04",16,0) N SDB,SDTRF "RTN","SDRPA04",17,0) S SDB=SDTOT\5000 I SDTOT-(5000*SDB)>0 S SDB=SDB+1 ;# of batches "RTN","SDRPA04",18,0) N NOW S NOW=$$NOW^XLFDT S SDTRF=$$FMTE^XLFDT(NOW,2),SDTRF=$P(SDTRF,":",1,2) "RTN","SDRPA04",19,0) N DA,DIE,DR D "RTN","SDRPA04",20,0) .S DA=CRUNID,DIE=409.6,DR="1.3///"_SDTOT_";1.4///"_SDB_";1.5///"_NOW D ^DIE "RTN","SDRPA04",21,0) D CLEAN(CRUNID) "RTN","SDRPA04",22,0) N SDS,SDSTAT,SDIP,SDAR,SDAP,SDMT,SDMS,SD870 "RTN","SDRPA04",23,0) ;SDS - STATION # "RTN","SDRPA04",24,0) ;SDSTAT - SD-PAIT STATUS "RTN","SDRPA04",25,0) ;SDAIP - IP ADDRESS "RTN","SDRPA04",26,0) ;SDAR - COMMIT ACK RECEIVED "RTN","SDRPA04",27,0) ;SDAP - COMMIT ACK PROCESSED "RTN","SDRPA04",28,0) ;SDMT - MESSAGES (BATCHES) TO SEND "RTN","SDRPA04",29,0) ;SDMS - MESSAGES (BATCHES) SENT "RTN","SDRPA04",30,0) S SD870=$O(^HLCS(870,"B","SD-PAIT","")) "RTN","SDRPA04",31,0) N ARRAY D GETS^DIQ(870,SD870_",","4;5;6;7;8;400.01","I","ARRAY") "RTN","SDRPA04",32,0) N SD87 S SD87=SD870_"," "RTN","SDRPA04",33,0) S SDSTAT=ARRAY(870,SD87,4,"I") "RTN","SDRPA04",34,0) S SDAR=ARRAY(870,SD87,5,"I") "RTN","SDRPA04",35,0) S SDAP=ARRAY(870,SD87,6,"I") "RTN","SDRPA04",36,0) S SDMS=ARRAY(870,SD87,7,"I") "RTN","SDRPA04",37,0) S SDMT=ARRAY(870,SD87,8,"I") "RTN","SDRPA04",38,0) S SDIP=ARRAY(870,SD87,400.01,"I") "RTN","SDRPA04",39,0) S SDS=$P($$SITE^VASITE(),"^",3) "RTN","SDRPA04",40,0) ;S SDS=$E($O(^SDWL(409.6,"AMSG","")),1,3) "RTN","SDRPA04",41,0) N SDBT,STSK,SDSL ; Starting and Last scanned date "RTN","SDRPA04",42,0) S SDBT=$P(^SDWL(409.6,CRUNID,0),U),SDSL=$P(^SDWL(409.6,CRUNID,0),U,4) "RTN","SDRPA04",43,0) S STSK=$P(^SDWL(409.6,CRUNID,0),U,2) "RTN","SDRPA04",44,0) S SDBT=$$FMTE^XLFDT(SDBT,2),SDSL=$$FMTE^XLFDT(SDSL,2) "RTN","SDRPA04",45,0) MSG ;send mail message "RTN","SDRPA04",46,0) N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ "RTN","SDRPA04",47,0) S XMSUB=$G(SDS)_" - PAIT BACKGROUND JOB" "RTN","SDRPA04",48,0) S XMY("G.SD-PAIT")="" "RTN","SDRPA04",49,0) S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" "RTN","SDRPA04",50,0) S XMTEXT="SDAMX(" "RTN","SDRPA04",51,0) S DUZ="" "RTN","SDRPA04",52,0) S XMDUZ="POSTMASTER" "RTN","SDRPA04",53,0) S SDAMX(1)="" "RTN","SDRPA04",54,0) S SDAMX(2)="The PAIT job has completed - TASK #: "_STSK_" Log #: "_CRUNID_" on "_SDTRF "RTN","SDRPA04",55,0) S SDAMX(3)="Started: "_SDBT_" Last Scanned: "_SDSL "RTN","SDRPA04",56,0) S SDAMX(4)="Pending appointments: "_$J(SDPEN,10) "RTN","SDRPA04",57,0) S SDAMX(5)="Final appointments: "_$J(SDFIN,10) "RTN","SDRPA04",58,0) S SDAMX(6)=" ----------" "RTN","SDRPA04",59,0) S SDAMX(7)="Total appointments: "_$J(SDTOT,10)_" Number of batches: "_SDB "RTN","SDRPA04",60,0) S SDAMX(8)="" "RTN","SDRPA04",61,0) S SDAMX(9)="Fac Log Bch Appt # Date finished IP Address Gen Sent Com R Com P Status" "RTN","SDRPA04",62,0) S SDAMX(10)="-----------------------------------------------------------------------" "RTN","SDRPA04",63,0) S SDAMX(11)=SDS_"|"_$J(CRUNID,3)_"|"_$J(SDB,3)_"|"_$J(SDTOT,7)_"|"_SDTRF_"|"_$J(SDIP,11)_"|"_$J(SDMT,4)_"|"_$J(SDMS,4)_"|"_$J(SDAR,4)_"|"_$J(SDAP,4)_"| "_SDSTAT "RTN","SDRPA04",64,0) S SDAMX(12)="" "RTN","SDRPA04",65,0) I $G(SDSTOP) S XMY("VHACIONHD@MED.VA.GOV")="" D D ^XMD Q "RTN","SDRPA04",66,0) .S SDAMX(13)="WARNING: TASK STOPPED BY USER, NEEDS TO BE RESTARTED." "RTN","SDRPA04",67,0) .S SDAMX(14)="Initiate a Remedy ticket TO FOLLOW UP." "RTN","SDRPA04",68,0) I 'SFF I SDMT>0!(SDB=0) D D ^XMD K ^TMP("SDDPT",$J) Q "RTN","SDRPA04",69,0) .I (SDMT-SDMS)=0 D Q "RTN","SDRPA04",70,0) ..S SDAMX(13)="SUCCESS: Transmission completed." "RTN","SDRPA04",71,0) .I (SDMT-SDMS)0 I (SDMT-SDMS)'0 I (SDMT-SDMS)'1 "RTN","SDRPA04",106,0) W !,"The repairing in progress...",! "RTN","SDRPA04",107,0) N SDE,SDEB,SDFE,SDLSD,SDRCNT,ZTSK "RTN","SDRPA04",108,0) S SDE=$G(^SDWL(409.6,RUN,0)) Q:SDE="" "RTN","SDRPA04",109,0) S ZTSK=$P(SDE,"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"Task "_ZTSK_"is still active!" Q "RTN","SDRPA04",110,0) S SDEB=+$P(SDE,"^",3) ; last batch # submitted to HL7 "RTN","SDRPA04",111,0) S SDRCNT=$O(^SDWL(409.6,RUN,1,999999999),-1) ;last entry "RTN","SDRPA04",112,0) I SDEB=0 S SDFE=0 S $P(^SDWL(409.6,RUN,0),U,4)=$P(^SDWL(409.6,RUN-1,0),U,4) "RTN","SDRPA04",113,0) I +SDEB>0 D "RTN","SDRPA04",114,0) .S SDFE=SDRCNT+1 F S SDFE=$O(^SDWL(409.6,RUN,1,SDFE),-1) I $P(^SDWL(409.6,RUN,1,SDFE,0),U,3)'>SDEB&($P(^SDWL(409.6,RUN,1,SDFE,0),U,3)'="") Q ; SD/491 "RTN","SDRPA04",115,0) .N SDLSD1 S SDLSD1=$P(^SDWL(409.6,RUN,1,SDFE,0),U,7) ;retrieve the last used creation date of HL7 created "RTN","SDRPA04",116,0) .N SDLSD2 S SDLSD2=$P($G(^SDWL(409.6,RUN,1,SDFE+1,0)),U,7) "RTN","SDRPA04",117,0) .S SDLSD=$P(SDE,U,4) ; last scanned date "RTN","SDRPA04",118,0) .I SDLSD="" D "RTN","SDRPA04",119,0) ..S $P(^SDWL(409.6,RUN,0),U,4)=$S(SDLSD2>SDLSD1:SDLSD1,1:SDLSD1-1) "RTN","SDRPA04",120,0) .E S $P(^SDWL(409.6,RUN,0),U,4)=SDLSD-1 "RTN","SDRPA04",121,0) N SDS,DIK F SDS=SDFE+1:1:SDRCNT I $D(^SDWL(409.6,RUN,1,SDS,0)) D EVAL(RUN,SDS) S DIK="^SDWL(409.6,"_RUN_",1,",DA(1)=RUN,DA=SDS D ^DIK "RTN","SDRPA04",122,0) S SDB=+$P($G(^SDWL(409.6,RUN,2,0)),U,3) "RTN","SDRPA04",123,0) S NOW=$$NOW^XLFDT,SDFE=5000*SDB "RTN","SDRPA04",124,0) S $P(^SDWL(409.6,RUN,0),U,5)=SDFE "RTN","SDRPA04",125,0) S $P(^SDWL(409.6,RUN,0),U,6)=SDB "RTN","SDRPA04",126,0) S $P(^SDWL(409.6,RUN,0),U,7)=NOW "RTN","SDRPA04",127,0) D MSGT(RUN,,,SDFE) "RTN","SDRPA04",128,0) W !!,"The last run number has been repaired, you may ONE TIME QUEUE the next one.",! "RTN","SDRPA04",129,0) Q "RTN","SDRPA04",130,0) EVAL(RUN,SDS) ; "RTN","SDRPA04",131,0) ;evaluate if to update any 'S' or 'R' Retention Flags for "RTN","SDRPA04",132,0) ;the previous entry if exists. "RTN","SDRPA04",133,0) N SDSTR,DFN,SDDT S SDSTR=^SDWL(409.6,RUN,1,SDS,0) "RTN","SDRPA04",134,0) S DFN=+SDSTR,SDDT=$P(SDSTR,"^",2) "RTN","SDRPA04",135,0) Q:SDDT="" "RTN","SDRPA04",136,0) ;find a prior entry SDRUN "RTN","SDRPA04",137,0) N SDRUN S SDRUN=$O(^SDWL(409.6,"AC",DFN,SDDT,RUN),-1) Q:SDRUN="" "RTN","SDRPA04",138,0) N SDSQ S SDSQ=$O(^SDWL(409.6,"AC",DFN,SDDT,SDRUN,"")) "RTN","SDRPA04",139,0) N SDSTRP S SDSTRP=^SDWL(409.6,SDRUN,1,SDSQ,0) "RTN","SDRPA04",140,0) N SDRET S SDRET=$P(SDSTRP,"^",5) "RTN","SDRPA04",141,0) I SDRET="S"!(SDRET="R") N DIC D "RTN","SDRPA04",142,0) .S SDRET="Y",DIC="^SDWL(409.6,"_SDRUN_",1,",DA(1)=SDRUN,DA=SDSQ,DIE=DIC,DR="4///"_SDRET D ^DIE "RTN","SDRPA04",143,0) Q "RTN","SDRPA05") 0^9^B24753499^B24254070 "RTN","SDRPA05",1,0) SDRPA05 ;BP-OIFO/ESW - Evaluate appointment status for HL7 ; 9/10/04 9:34am "RTN","SDRPA05",2,0) ;;5.3;Scheduling;**290,333,349,376,491**;AUG 13, 2003;Build 53 "RTN","SDRPA05",3,0) ;Evaluation of the appointment status is done from the computed field to match the displayed/printed status in the appointment management "RTN","SDRPA05",4,0) ;SD/491 - MODIFIED $$SCHEDULE to cut off appointments considered as rescheduled by with the scheduled date<2250000 "RTN","SDRPA05",5,0) Q "RTN","SDRPA05",6,0) ; "RTN","SDRPA05",7,0) STATUS(DFN,SDADT,SDCL,TODAY,SFD) ; "RTN","SDRPA05",8,0) ;Input: "RTN","SDRPA05",9,0) ; SDADT - Appt date/time "RTN","SDRPA05",10,0) ; SDCL - Clinic IEN "RTN","SDRPA05",11,0) ; SFD: - 0 - if called from scanning previous runs - update "RTN","SDRPA05",12,0) ; - 1 - if called from scanning 2.98 "RTN","SDRPA05",13,0) ;Output: "RTN","SDRPA05",14,0) ; SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL_U_SD8RD "RTN","SDRPA05",15,0) ; where: "RTN","SDRPA05",16,0) ; SDMSH -HL7 segment "RTN","SDRPA05",17,0) ; SD25 - Filler Status: "RTN","SDRPA05",18,0) ; P - Pending "RTN","SDRPA05",19,0) ; F - Final "RTN","SDRPA05",20,0) ; SD6 - Event Reason "RTN","SDRPA05",21,0) ; SD8 - Appt Type "RTN","SDRPA05",22,0) ; SD8RD - rescheduled date/time if SD8="RS" "RTN","SDRPA05",23,0) ; SDCO - check out date "RTN","SDRPA05",24,0) ; SDCLL - clinic IEN from matching encounter "RTN","SDRPA05",25,0) ; "RTN","SDRPA05",26,0) N SD0,SDST,SD6,SD8,SD25,SDMSH,SDCO,SDSTAT,SD8S,SD8RD "RTN","SDRPA05",27,0) S SDST=$$GET1^DIQ(2.98,SDADT_","_DFN_",",3,"I") "RTN","SDRPA05",28,0) I SDST'="" I SDST'="NT"&(SDST'="I") D Q SDSTAT "RTN","SDRPA05",29,0) .S SD25="F",SDCO="",SD8RD="" "RTN","SDRPA05",30,0) .I SDST="C" S SD6="CC",SD8="",SDMSH="S15" D ;cancel by clinic "RTN","SDRPA05",31,0) ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) "RTN","SDRPA05",32,0) .I SDST="CA" S SD6="CC",SD8="ABK",SDMSH="S15" ;cancel bt clinic and auto rebook "RTN","SDRPA05",33,0) .I SDST="PC" S SD6="CP",SD8="",SDMSH="S15" D ; cancel by patient "RTN","SDRPA05",34,0) ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) "RTN","SDRPA05",35,0) .I SDST="PCA" S SD6="CP",SD8="ABK",SDMSH="S15" ;cancel by patient and auto rebook "RTN","SDRPA05",36,0) .I SDST="NA" S SD6="NS",SD8="ABK",SDMSH="S26" ;no show and auto rebook "RTN","SDRPA05",37,0) .I SDST="N" S SD6="NS",SD8="",SDMSH="S26" ;no show "RTN","SDRPA05",38,0) .;evaluate 'non-count' "RTN","SDRPA05",39,0) .I $P($G(^SC(SDCL,0)),U,17)="Y" D "RTN","SDRPA05",40,0) ..I SD8="" S SD8="NC" Q "RTN","SDRPA05",41,0) ..I SD8="RS" S SD8="RSN" "RTN","SDRPA05",42,0) .; "RTN","SDRPA05",43,0) .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD "RTN","SDRPA05",44,0) ;process all others "RTN","SDRPA05",45,0) S SD0=^DPT(DFN,"S",SDADT,0) "RTN","SDRPA05",46,0) ; check out from OUTPAT ENCOUNTER "RTN","SDRPA05",47,0) ;N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0 S SDCO=$P(^SCE(SCE,0),"^",7) "RTN","SDRPA05",48,0) N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0,$D(^SCE(SCE,0)) S SDCO=$P(^SCE(SCE,0),"^",7) "RTN","SDRPA05",49,0) N SDSTATX,SDX3 "RTN","SDRPA05",50,0) S SDSTATX=$$STATUS^SDAM1(DFN,SDADT,SDCL,SD0) ;call to compute the status (VistA) "RTN","SDRPA05",51,0) ;SDSTATX=Appt status IFN in 409.63 ; status name ; print status ; check in ; check out "RTN","SDRPA05",52,0) I SDCO="" S SDCO=$P(SDSTATX,";",5) ; check out from clinic if NULL "RTN","SDRPA05",53,0) I SDCO'=""&(+SDSTATX'=12) D Q SDSTAT "RTN","SDRPA05",54,0) .S SD6="CO",SD25="F",SD8="",SD8RD="",SDMSH=$S(SFD=0:"S14",1:"S12") "RTN","SDRPA05",55,0) .I +SDSTATX=3 S SD8="AR" ; action required "RTN","SDRPA05",56,0) .I +SDSTATX=8 S SD8="I" ;inpatient "RTN","SDRPA05",57,0) .;I +SDSTATX=12 S SD8="NC" ;non-count excluded to be compared to possible encounter does not matter if check out "RTN","SDRPA05",58,0) .I +SDSTATX=2 S SD8="O" ;outpatient "RTN","SDRPA05",59,0) .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD "RTN","SDRPA05",60,0) I +SDSTATX=3 D Q SDSTAT "RTN","SDRPA05",61,0) .S SD25="P",SDMSH="S12",SDCO="",SD8RD="" "RTN","SDRPA05",62,0) .I $P(SDSTATX,";",4)'="" S SD6="CI",SD8="AR" ;check in/action required "RTN","SDRPA05",63,0) .E S SD6="",SD8="NAT",SD8RD="" ;no action taken "RTN","SDRPA05",64,0) .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD "RTN","SDRPA05",65,0) I +SDSTATX=8!(+SDSTATX=11) S SD25="P",SD8RD="" D Q SDSTAT "RTN","SDRPA05",66,0) .I +SDSTATX=8 S SD6="",SD8="I",SDCO="",SDMSH="S12" ;inpatient "RTN","SDRPA05",67,0) .I +SDSTATX=11 S SD6="",SD8="F",SDCO="",SDMSH="S12" ;future "RTN","SDRPA05",68,0) .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD "RTN","SDRPA05",69,0) ; "RTN","SDRPA05",70,0) ;process non-count (not checked out) "RTN","SDRPA05",71,0) I +SDSTATX=12 N SDCLL S SDCLL="" D S:SD6'="COE" SDCLL=SDCL S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL Q SDSTAT "RTN","SDRPA05",72,0) .S SD6="",SD8="NC",SDCO="",SDMSH="S12",SD25="P" "RTN","SDRPA05",73,0) .I (SDADT\1)-(TODAY\1)>0 S SD6="",SD8="NCF",SD25="P" Q "RTN","SDRPA05",74,0) .N SDADTC,SDSCE,SDADTCK S SDADTC=(SDADT\1)-1+.99,SDADTCK=SDADTC+1 F D Q:'SDSCE!(SD6="COE") "RTN","SDRPA05",75,0) ..S SDSCE=$$EXAE^SDOE(DFN,SDADTC,SDADTCK) "RTN","SDRPA05",76,0) ..I SDSCE>1 N SDDATA D GETGEN^SDOE(SDSCE,"SDDATA") D "RTN","SDRPA05",77,0) ...N SDCL0,SDCL1,SDCL2 "RTN","SDRPA05",78,0) ...S SDCLL=$P(SDDATA(0),"^",4) I $P(^SC(SDCLL,0),"^",17)="Y" D Q "RTN","SDRPA05",79,0) ....S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 ; "RTN","SDRPA05",80,0) ...S SDCL0=$P(^SC(SDCL,0),"^",7)_$P(^SC(SDCL,0),"^",18) "RTN","SDRPA05",81,0) ...S SDCL2=$P(^SC(SDCLL,0),"^",7)_$P(^SC(SDCLL,0),"^",18) "RTN","SDRPA05",82,0) ...I SDCL0'=SDCL2 S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 Q "RTN","SDRPA05",83,0) ...; proceed if the same DSS IDs pairs "RTN","SDRPA05",84,0) ...S SDCO=$P(SDDATA(0),"^",7) "RTN","SDRPA05",85,0) ...I SDCO'="" S SD6="COE",SD25="F",SDMSH=$S(SFD=0:"S14",1:"S12") Q "RTN","SDRPA05",86,0) ...;encounter exists but not in final (chek out) status "RTN","SDRPA05",87,0) ...S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 "RTN","SDRPA05",88,0) .I SD6="COE" Q "RTN","SDRPA05",89,0) .;check out by matching encounter "RTN","SDRPA05",90,0) .E I ((TODAY\1)-(SDADT\1))>2 D ;give 2 days to update "RTN","SDRPA05",91,0) ..S SD6="NM",SD25="F",SDMSH=$S(SFD=0:"S14",1:0) ;no match, to be skipped "RTN","SDRPA05",92,0) Q 0 "RTN","SDRPA05",93,0) ; "RTN","SDRPA05",94,0) SCHEDULE(DFN,SDCL,SDADT) ; Scheduling flag "RTN","SDRPA05",95,0) ; If the patient has another appointment created on the same day as the cancellation date of the canceled appt, and that "RTN","SDRPA05",96,0) ; appointment is created for a clinic with the same stop code then return "RS". "RTN","SDRPA05",97,0) ; If there is not another appointment made on the same day, return "". "RTN","SDRPA05",98,0) N SDCDT,SDCLN S SDCDT=$$GET1^DIQ(2.98,SDADT_","_DFN_",",15,"I") ;cancellation date "RTN","SDRPA05",99,0) Q:'SDCDT "" "RTN","SDRPA05",100,0) N SDCDTI S SDCDTI=SDCDT\1 "RTN","SDRPA05",101,0) N SDRESCH S SDRESCH="" "RTN","SDRPA05",102,0) ;exclude the same appointments "RTN","SDRPA05",103,0) N SDAPDT S SDAPDT="" F S SDAPDT=$O(^DPT("ASADM",SDCDTI,DFN,SDAPDT)) Q:SDAPDT="" I SDAPDT>3030000 I SDAPDT'=SDADT I $D(^DPT(DFN,"S",SDAPDT)) D Q:SDRESCH'="" "RTN","SDRPA05",104,0) .S SDCLN=+$P(^DPT(DFN,"S",SDAPDT,0),U) I $P(^SC(SDCLN,0),"^",7)=$P(^SC(SDCL,0),"^",7) S SDRESCH="RS"_"^"_SDAPDT ;compare stop code pointers "RTN","SDRPA05",105,0) S:SDRESCH="" SDRESCH="^" Q SDRESCH "RTN","SDRPA06") 0^10^B58773674^B58400495 "RTN","SDRPA06",1,0) SDRPA06 ;bp-oifo/swo pait hl7 ack handling ; 10/31/04 3:53pm "RTN","SDRPA06",2,0) ;;5.3;Scheduling;**290,333,349,376,491**;AUG 13, 1993;Build 53 "RTN","SDRPA06",3,0) ;routine called from Vista HL7 when ack messages are received in response "RTN","SDRPA06",4,0) ;to an out going HL7 message generated by protocol SC-PAIT-EVENT "RTN","SDRPA06",5,0) ACK ;entry point from Vista HL7 "RTN","SDRPA06",6,0) ;ACKDATE : date/time ack received "RTN","SDRPA06",7,0) ;FLDSEP : field separator "RTN","SDRPA06",8,0) ;CMPNTSEP : component separator "RTN","SDRPA06",9,0) ;REPTNSEP : repetition separator "RTN","SDRPA06",10,0) ;ACKCODE : acknowledgement code "RTN","SDRPA06",11,0) ;ERROR : reject reason "RTN","SDRPA06",12,0) ;BATCHID : batch control ID "RTN","SDRPA06",13,0) ;BATCHIDO : original batch control ID "RTN","SDRPA06",14,0) N ACKCODE,ACKDATE,BATCHID,BATCHIDO,CMPNTSEP,ERROR,FLDSEP,REPTNSEP,RUNIEN,SDZAP,V1 "RTN","SDRPA06",15,0) ;disable automatic repair of the last run, not needed to process acks "RTN","SDRPA06",16,0) ;NHD will be notified when the completion message does not come out "RTN","SDRPA06",17,0) ;D RSTAT^SDRPA02 ;check the status of the last run "RTN","SDRPA06",18,0) K ^TMP("SDRPA06",$J) "RTN","SDRPA06",19,0) S SDZAP=0 "RTN","SDRPA06",20,0) S ACKDATE=$$NOW^XLFDT() "RTN","SDRPA06",21,0) S FLDSEP=HL("FS") "RTN","SDRPA06",22,0) S CMPNTSEP=$E(HL("ECH"),1) "RTN","SDRPA06",23,0) S REPTNSEP=$E(HL("ECH"),2) "RTN","SDRPA06",24,0) S ACKCODE=$P(HLMSA,FLDSEP) "RTN","SDRPA06",25,0) S ERROR=$P(HLMSA,FLDSEP,4) "RTN","SDRPA06",26,0) S (BATCHID,BATCHIDO)=$P(HLMSA,FLDSEP,2) "RTN","SDRPA06",27,0) S RUNIEN=$$RUNIEN(BATCHIDO) Q:'RUNIEN "RTN","SDRPA06",28,0) S BATCHID=$$OURB(RUNIEN,BATCHIDO) ;convert to our batch id "RTN","SDRPA06",29,0) Q:'BATCHID ;error needs to be handled "RTN","SDRPA06",30,0) ;S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")),RUNIEN=$O(^SDWL(409.6,"AMSG",BATCHID,V1,"")) "RTN","SDRPA06",31,0) S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")) Q:V1="" "RTN","SDRPA06",32,0) Q:'$$DUP^SDRPA02(RUNIEN,BATCHIDO) ;check for duplicate "RTN","SDRPA06",33,0) S ^XTMP("SDRPA-"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),3)_"^"_$$DT^XLFDT() ;set xtmp global for diagnostics "RTN","SDRPA06",34,0) I $E(ACKCODE,1,2)="AR" D AR(BATCHID,BATCHIDO),MSG(BATCHIDO,3,RUNIEN,BATCHID) Q ;whole batch rejection "RTN","SDRPA06",35,0) ;Q:($E(ACKCODE,1,2)'="AA") ;quit if not a application ack "RTN","SDRPA06",36,0) ;will only be 2 ACKCODEs AA and AE so don't have to screen anymore "RTN","SDRPA06",37,0) F X HLNEXT Q:(HLQUIT'>0) D ;start looping the msg text "RTN","SDRPA06",38,0) . Q:($E(HLNODE,1,3)'="MSA") ;skip if not a MSA segment "RTN","SDRPA06",39,0) . I $P(HLNODE,FLDSEP,2)="AE" D ;it's an error "RTN","SDRPA06",40,0) .. Q:($P($P(HLNODE,FLDSEP,3),"-",2))="" ;no message number "RTN","SDRPA06",41,0) .. S ^TMP("SDRPA06",$J,+$P($P(HLNODE,FLDSEP,3),"-",2))=+$P(HLNODE,"^",4) ;set xref with message # "RTN","SDRPA06",42,0) I '$D(^TMP("SDRPA06",$J)) D AA(BATCHID,BATCHIDO),MSG(BATCHIDO,2,RUNIEN,BATCHID) Q ;whole batch accept "RTN","SDRPA06",43,0) D AAAR(BATCHID,BATCHIDO),MSG(BATCHIDO,1,RUNIEN,BATCHID) ;batch accept with errors "RTN","SDRPA06",44,0) Q "RTN","SDRPA06",45,0) AR(BATCH,BATCHIDO) ;whole batch rejection "RTN","SDRPA06",46,0) ;BATCH : originating batch number "RTN","SDRPA06",47,0) ;BATCHIDO : original batch number from HL7 ACK "RTN","SDRPA06",48,0) ;V1 : sequence # (individual message number in batch) "RTN","SDRPA06",49,0) ;V2 : run # (ien of multiple entry) "RTN","SDRPA06",50,0) ;V3 : ien (ien in patient multiple) "RTN","SDRPA06",51,0) ;V4 : ien (ien batch tracking multiple) "RTN","SDRPA06",52,0) Q:($G(BATCH)="") "RTN","SDRPA06",53,0) N DA,DIE,DR,V1,V2,V3,V4,ZNODE "RTN","SDRPA06",54,0) S V1=0 "RTN","SDRPA06",55,0) F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D "RTN","SDRPA06",56,0) . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 "RTN","SDRPA06",57,0) . ;batch tracking enhancement "RTN","SDRPA06",58,0) . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D "RTN","SDRPA06",59,0) .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE "RTN","SDRPA06",60,0) .. D ^DIE K DIE "RTN","SDRPA06",61,0) . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D "RTN","SDRPA06",62,0) .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" "RTN","SDRPA06",63,0) .. ;4TH PIECE IS MESSAGE NUMBER "RTN","SDRPA06",64,0) .. S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," "RTN","SDRPA06",65,0) .. S DR="7////"_$O(^SCPT(404.472,"B","R","")) D ^DIE "RTN","SDRPA06",66,0) .. I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q "RTN","SDRPA06",67,0) .. I $D(^SDWL(409.6,"AE","N",V2,V3)) D "RTN","SDRPA06",68,0) ... S DR="4///Y" D ^DIE "RTN","SDRPA06",69,0) Q "RTN","SDRPA06",70,0) AA(BATCH,BATCHIDO) ;whole batch accept "RTN","SDRPA06",71,0) ;if the batch is accepted and no rejections then get the run # sequence # "RTN","SDRPA06",72,0) ;from AMSG xref. If no "AE","Y" xref then call DIK to delete the entry "RTN","SDRPA06",73,0) ;BATCH : originating batch number "RTN","SDRPA06",74,0) ;BATCHIDO : original batch number from HL7 ACK "RTN","SDRPA06",75,0) ;V1 : sequence # (individual message number in batch) "RTN","SDRPA06",76,0) ;V2 : run # (ien of multiple entry) "RTN","SDRPA06",77,0) ;V3 : ien (ien in patient multiple) "RTN","SDRPA06",78,0) ;V4 : ien (ien batch tracking multiple) "RTN","SDRPA06",79,0) Q:($G(BATCH)="") "RTN","SDRPA06",80,0) N DA,DIK,DR,V1,V2,V3,V4,ZNODE "RTN","SDRPA06",81,0) S V1=0 "RTN","SDRPA06",82,0) F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D "RTN","SDRPA06",83,0) . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 "RTN","SDRPA06",84,0) . ;batch tracking enhancement "RTN","SDRPA06",85,0) . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D "RTN","SDRPA06",86,0) .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE "RTN","SDRPA06",87,0) .. D ^DIE K DIE "RTN","SDRPA06",88,0) . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D "RTN","SDRPA06",89,0) .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" "RTN","SDRPA06",90,0) .. ;4th piece is the message # "RTN","SDRPA06",91,0) .. I '$D(^SDWL(409.6,"AE","Y",V2,V3)) D "RTN","SDRPA06",92,0) ... S DIK="^SDWL(409.6,"_V2_",1," "RTN","SDRPA06",93,0) ... S DA(1)=V2,DA=V3 D ^DIK "RTN","SDRPA06",94,0) ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics "RTN","SDRPA06",95,0) Q "RTN","SDRPA06",96,0) AAAR(BATCH,BATCHIDO) ;batch accept with errors "RTN","SDRPA06",97,0) ;BATCH : originating batch number "RTN","SDRPA06",98,0) ;BATCHIDO : original batch number from HL7 ACK "RTN","SDRPA06",99,0) ;V1 : sequence # (individual message number in batch) "RTN","SDRPA06",100,0) ;V2 : run # (ien of multiple entry) "RTN","SDRPA06",101,0) ;V3 : ien (ien in patient multiple) "RTN","SDRPA06",102,0) ;V4 : ien (ien batch tracking multiple)) "RTN","SDRPA06",103,0) Q:($G(BATCH)="") "RTN","SDRPA06",104,0) N DA,DIK,DR,V1,V2,V3,V4,ZNODE "RTN","SDRPA06",105,0) S V1=0 "RTN","SDRPA06",106,0) F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D "RTN","SDRPA06",107,0) . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 "RTN","SDRPA06",108,0) . ;batch tracking enhancement "RTN","SDRPA06",109,0) . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D "RTN","SDRPA06",110,0) .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE "RTN","SDRPA06",111,0) .. D ^DIE K DIE "RTN","SDRPA06",112,0) . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D "RTN","SDRPA06",113,0) .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" "RTN","SDRPA06",114,0) .. ;4th piece is the message # "RTN","SDRPA06",115,0) .. ;next line screens for accepted batch + accepted message + status final and can be deleted "RTN","SDRPA06",116,0) .. I '$D(^SDWL(409.6,"AE","Y",V2,V3))&('$D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4)))) D "RTN","SDRPA06",117,0) ... S DIK="^SDWL(409.6,"_V2_",1," "RTN","SDRPA06",118,0) ... S DA(1)=V2,DA=V3 D ^DIK "RTN","SDRPA06",119,0) ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics "RTN","SDRPA06",120,0) .. ;next line screens for accepted batch + error message "RTN","SDRPA06",121,0) .. I $D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))) D "RTN","SDRPA06",122,0) ... S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," "RTN","SDRPA06",123,0) ... S DR="7////"_$O(^SCPT(404.472,"B",$G(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))),"")) D ^DIE "RTN","SDRPA06",124,0) ... I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q "RTN","SDRPA06",125,0) ... I $D(^SDWL(409.6,"AE","N",V2,V3)) D "RTN","SDRPA06",126,0) .... S DR="4///Y" D ^DIE "RTN","SDRPA06",127,0) Q "RTN","SDRPA06",128,0) CLEAN(RUN) ;housekeeping "RTN","SDRPA06",129,0) ;clean up batch previous to current one by checking for "AE",("S" or "R") xref and "RTN","SDRPA06",130,0) ;deleting if entry in xref exists "RTN","SDRPA06",131,0) ;RUN : run # (ien of multiple entry) "RTN","SDRPA06",132,0) ;V1 : previous run # (ien of multiple entry) "RTN","SDRPA06",133,0) ;V2 : ien (ien in multiple) "RTN","SDRPA06",134,0) Q:($G(RUN)="") "RTN","SDRPA06",135,0) N V1,V2,V3 "RTN","SDRPA06",136,0) S V1=$O(^SDWL(409.6,RUN),-1) Q:'V1 "RTN","SDRPA06",137,0) F V3="R","S" S V2=0 F S V2=$O(^SDWL(409.6,"AE",V3,V1,V2)) Q:'V2 D "RTN","SDRPA06",138,0) . S ZNODE=$G(^SDWL(409.6,V1,1,V2,0)) "RTN","SDRPA06",139,0) . S DIK="^SDWL(409.6,"_V1_",1," "RTN","SDRPA06",140,0) . S DA(1)=V1,DA=V2 D ^DIK "RTN","SDRPA06",141,0) . S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),"CLEAN",+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics "RTN","SDRPA06",142,0) Q "RTN","SDRPA06",143,0) MSG(BATCHIDO,TYPE,RUNIEN,BATCHID) ;acknowledgement notification to mail group "RTN","SDRPA06",144,0) ;BATCHID : Our Message ID "RTN","SDRPA06",145,0) ;BATCHIDO: Batch Control ID "RTN","SDRPA06",146,0) ;TYPE : type of message (accept with rejects - 1, whole accept 2, whole reject -3) "RTN","SDRPA06",147,0) ;RUNIEN : run ien associated with this batch "RTN","SDRPA06",148,0) ;SDAMX : message text array "RTN","SDRPA06",149,0) ;XMSUB : subject "RTN","SDRPA06",150,0) ;XMY : addressee "RTN","SDRPA06",151,0) ;XMTEXT : location of text array "RTN","SDRPA06",152,0) ;XMDUZ : sender of the message "RTN","SDRPA06",153,0) ;RUNZ : zero node of run associated with this batch "RTN","SDRPA06",154,0) N RUNZ,SDAMX,V0,V1,V2,V3,XMSUB,XMY,XMTEXT,XMDUZ "RTN","SDRPA06",155,0) Q:BATCHID="" "RTN","SDRPA06",156,0) L +^SDWL(409.6,RUNIEN,2,0) "RTN","SDRPA06",157,0) S V0=$P($G(^SDWL(409.6,RUNIEN,2,0)),"^",4) "RTN","SDRPA06",158,0) S (V1,V3)=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,V1)) Q:'V1 D "RTN","SDRPA06",159,0) . S:$P($G(^SDWL(409.6,RUNIEN,2,V1,0)),"^",4)'="" V3=V3+1 "RTN","SDRPA06",160,0) L -^SDWL(409.6,RUNIEN,2,0) "RTN","SDRPA06",161,0) S RUNZ=$G(^SDWL(409.6,RUNIEN,0)) "RTN","SDRPA06",162,0) S XMSUB="PAIT BATCH ACKNOWLEGEMENT "_BATCHIDO "RTN","SDRPA06",163,0) S XMY("G.SD-PAIT")="" "RTN","SDRPA06",164,0) S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" "RTN","SDRPA06",165,0) S XMTEXT="SDAMX(" "RTN","SDRPA06",166,0) S XMDUZ="POSTMASTER" "RTN","SDRPA06",167,0) I TYPE=1 D "RTN","SDRPA06",168,0) . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) "RTN","SDRPA06",169,0) . S SDAMX(2)="Batch Control ID: "_BATCHIDO "RTN","SDRPA06",170,0) . S SDAMX(3)=" Message ID: "_BATCHID "RTN","SDRPA06",171,0) . S SDAMX(4)=" Log Entry: "_RUNIEN "RTN","SDRPA06",172,0) . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) "RTN","SDRPA06",173,0) . S SDAMX(6)=" Status: Acknowledged - with rejections " "RTN","SDRPA06",174,0) . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" "RTN","SDRPA06",175,0) . S SDAMX(8)="" "RTN","SDRPA06",176,0) . S SDAMX(9)="Use option SD-PAIT REJECTED Rejected Transmissions to view the rejections." "RTN","SDRPA06",177,0) I TYPE=2 D "RTN","SDRPA06",178,0) . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) "RTN","SDRPA06",179,0) . S SDAMX(2)="Batch Control ID: "_BATCHIDO "RTN","SDRPA06",180,0) . S SDAMX(3)=" Message ID: "_BATCHID "RTN","SDRPA06",181,0) . S SDAMX(4)=" Log Entry: "_RUNIEN "RTN","SDRPA06",182,0) . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) "RTN","SDRPA06",183,0) . S SDAMX(6)=" Status: Acknowledged - No Rejections" "RTN","SDRPA06",184,0) . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" "RTN","SDRPA06",185,0) I TYPE=3 D "RTN","SDRPA06",186,0) . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) "RTN","SDRPA06",187,0) . S SDAMX(2)="Batch Control ID: "_BATCHIDO "RTN","SDRPA06",188,0) . S SDAMX(3)=" Message ID: "_BATCHID "RTN","SDRPA06",189,0) . S SDAMX(4)=" Log Entry: "_RUNIEN "RTN","SDRPA06",190,0) . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) "RTN","SDRPA06",191,0) . S SDAMX(6)=" Status: Acknowledged - Entire Batch Rejected" "RTN","SDRPA06",192,0) . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" "RTN","SDRPA06",193,0) D ^XMD "RTN","SDRPA06",194,0) Q "RTN","SDRPA06",195,0) OURB(RUNIEN,BATCHIDO) ;match batch id to msg control id ("AMSG" xref) "RTN","SDRPA06",196,0) ;RUNIEN : the ien in file 409.6 of the run "RTN","SDRPA06",197,0) ;BATCHIDO : batchid pulled from the ACK message "RTN","SDRPA06",198,0) ;V2 : returns 0 if none, or msg control id "RTN","SDRPA06",199,0) N V1,V2,VNODE "RTN","SDRPA06",200,0) S V2=0 "RTN","SDRPA06",201,0) I '$G(RUNIEN) Q V2 "RTN","SDRPA06",202,0) I '$G(BATCHIDO) Q V2 "RTN","SDRPA06",203,0) I $G(^SDWL(409.6,RUNIEN,2,0))="" Q V2 "RTN","SDRPA06",204,0) S V1=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,"B",BATCHIDO,V1)) Q:'V1 D "RTN","SDRPA06",205,0) . S VNODE=$G(^SDWL(409.6,RUNIEN,2,V1,0)) Q:VNODE="" "RTN","SDRPA06",206,0) . I $P(VNODE,"^",3)="" Q "RTN","SDRPA06",207,0) . S V2=$P(VNODE,"^",3) Q "RTN","SDRPA06",208,0) Q V2 "RTN","SDRPA06",209,0) RUNIEN(BATCHID) ;get runien "RTN","SDRPA06",210,0) N V1,V2 "RTN","SDRPA06",211,0) S V2=0 "RTN","SDRPA06",212,0) S V1=999999999 F S V1=$O(^SDWL(409.6,V1),-1) Q:'V1!(V2) D "RTN","SDRPA06",213,0) . I $O(^SDWL(409.6,V1,2,"B",BATCHID,"")) S V2=V1 Q "RTN","SDRPA06",214,0) Q V2 "RTN","SDWLCU3") 0^14^B9829968^B12290803 "RTN","SDWLCU3",1,0) SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03 "RTN","SDWLCU3",2,0) ;;5.3;scheduling;**280,491**;AUG 13 1993;Build 53 "RTN","SDWLCU3",3,0) ; "RTN","SDWLCU3",4,0) ;modify update of 409.32 and related 409.3 with a proper institution set up in file 44 "RTN","SDWLCU3",5,0) ;through the division path "RTN","SDWLCU3",6,0) ; "RTN","SDWLCU3",7,0) 3 ;service specialty edit "RTN","SDWLCU3",8,0) S SDWLSS="",SDWLINS="",SDWLERR="" "RTN","SDWLCU3",9,0) F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1 "RTN","SDWLCU3",10,0) .F S SDWLSS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS)) Q:SDWLSS="" D Q:SDWLERR=1 "RTN","SDWLCU3",11,0) ..I '$D(SDWLSSV) S SDWLSSV=SDWLSS "RTN","SDWLCU3",12,0) ..S NAME=$$GET1^DIQ(4,SDWLINS_",",.01) "RTN","SDWLCU3",13,0) ..S SDWLSSN=$P(^SDWL(409.31,SDWLSS,0),U,1) "RTN","SDWLCU3",14,0) ..W !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01)," INSTITUTION: ",NAME "RTN","SDWLCU3",15,0) ..S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0)) D:SDWLSSX'="" SEL "RTN","SDWLCU3",16,0) S WLTC3="" "RTN","SDWLCU3",17,0) Q "RTN","SDWLCU3",18,0) SEL ;select new Insitition "RTN","SDWLCU3",19,0) N DIR "RTN","SDWLCU3",20,0) S DIR("A")="Select Institution: " "RTN","SDWLCU3",21,0) S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR "RTN","SDWLCU3",22,0) I X["^" S SDWLERR=1 Q "RTN","SDWLCU3",23,0) I Y<1 W *7,"Invalid Entry" G SEL "RTN","SDWLCU3",24,0) S SDWLINSN=+Y "RTN","SDWLCU3",25,0) D C3,C31 K DIC,D0,D1 "RTN","SDWLCU3",26,0) Q "RTN","SDWLCU3",27,0) C3 ; "RTN","SDWLCU3",28,0) ;check entry to see if it already exist "RTN","SDWLCU3",29,0) S DA=SDWLSSX,DA(1)=SDWLSS "RTN","SDWLCU3",30,0) I $O(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0)) D "RTN","SDWLCU3",31,0) . W !,"Institution already exists for this Specialty...deleting." "RTN","SDWLCU3",32,0) . S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK "RTN","SDWLCU3",33,0) E D "RTN","SDWLCU3",34,0) . W ! S DR=".01////^S X=SDWLINSN",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE "RTN","SDWLCU3",35,0) K DA,DA(1),DR,DIE,DIK "RTN","SDWLCU3",36,0) Q "RTN","SDWLCU3",37,0) C31 ;update SD WAIT LIST PATIENT file 409.3 "RTN","SDWLCU3",38,0) S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA)) Q:SDWLDA="" D "RTN","SDWLCU3",39,0) .S DR="2////^S X=SDWLINSN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE "RTN","SDWLCU3",40,0) .K DR,DIE,DA "RTN","SDWLCU3",41,0) .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($J,"EWL",$J,SDWLDA) "RTN","SDWLCU3",42,0) Q "RTN","SDWLCU3",43,0) 4 ;specific clinic edit "RTN","SDWLCU3",44,0) N SDWLERR,SDWLSC,SDWLINS S SDWLSC="",SDWLINS="",SDWLERR="" "RTN","SDWLCU3",45,0) F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D "RTN","SDWLCU3",46,0) .F S SDWLSC=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC)) Q:SDWLSC="" D UPDINS^SDWLCU5(SDWLSC,.SDWLERR) "RTN","SDWLCU3",47,0) Q:SDWLERR "RTN","SDWLCU3",48,0) S WLTC4="" "RTN","SDWLCU3",49,0) K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK "RTN","SDWLCU3",50,0) Q "RTN","SDWLCU3",51,0) C41 ;update wait list file "RTN","SDWLCU3",52,0) S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA)) Q:SDWLDA="" D "RTN","SDWLCU3",53,0) .S SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") "RTN","SDWLCU3",54,0) .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($J,"EWL",$J,SDWLDA),SDWLIN "RTN","SDWLCU3",55,0) Q "RTN","SDWLCU3",56,0) SEL1 ;select valid institution "RTN","SDWLCU3",57,0) N DIR "RTN","SDWLCU3",58,0) W !!,"Invalid Institution. Please select a National Institution.",! "RTN","SDWLCU3",59,0) W "CLINIC: ",CLNAM," INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01) "RTN","SDWLCU3",60,0) S DIR("A")="Select Institution: " "RTN","SDWLCU3",61,0) S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR "RTN","SDWLCU3",62,0) I X["^" S SDWLERR=1 Q "RTN","SDWLCU3",63,0) I Y<1 W *7,"Invalid Entry" G SEL1 "RTN","SDWLCU3",64,0) S SDWLINSN=+Y "RTN","SDWLCU3",65,0) Q "RTN","SDWLCU5") 0^1^B43176687^B26978724 "RTN","SDWLCU5",1,0) SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03 ; Compiled August 20, 2007 17:04:58 "RTN","SDWLCU5",2,0) ;;5.3;scheduling;**280,427,491**;AUG 13 1993;Build 53 "RTN","SDWLCU5",3,0) EN ; "RTN","SDWLCU5",4,0) W !!,"Checking file 404.51 one last time.",! "RTN","SDWLCU5",5,0) S SDWLERR="",TEAM=0 F S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM D Q:SDWLERR=1 "RTN","SDWLCU5",6,0) . S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I") "RTN","SDWLCU5",7,0) . S CODE=$$GET1^DIQ(4,INST_",",11,"I") "RTN","SDWLCU5",8,0) . S INCK=$$TF^XUAF4(INST) "RTN","SDWLCU5",9,0) . I CODE'="N"!('INCK) D "RTN","SDWLCU5",10,0) .. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01)," INSTITUTION: " "RTN","SDWLCU5",11,0) .. W $$GET1^DIQ(4,INST_",",.01) "RTN","SDWLCU5",12,0) .. D EDIT^SDWLCU2 "RTN","SDWLCU5",13,0) Q:SDWLERR=1 "RTN","SDWLCU5",14,0) ; "RTN","SDWLCU5",15,0) W !!,"Checking file 409.31 one last time.",! "RTN","SDWLCU5",16,0) 40931 S SDWLSS=0 F S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS D Q:SDWLERR=1 "RTN","SDWLCU5",17,0) . S SDWLINS="" F S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS D Q:SDWLERR=1 "RTN","SDWLCU5",18,0) .. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I") "RTN","SDWLCU5",19,0) .. S INCK=$$TF^XUAF4(SDWLINS) "RTN","SDWLCU5",20,0) .. I CODE'="N"!('INCK) D "RTN","SDWLCU5",21,0) ... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01)," INSTITUTION: " "RTN","SDWLCU5",22,0) ... W $$GET1^DIQ(4,SDWLINS_",",.01) "RTN","SDWLCU5",23,0) ... D GETINS Q:SDWLERR=1 "RTN","SDWLCU5",24,0) ... S SDWLSSX="" F S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX D Q:SDWLERR=1 "RTN","SDWLCU5",25,0) .... D C3^SDWLCU3 "RTN","SDWLCU5",26,0) Q:SDWLERR=1 "RTN","SDWLCU5",27,0) 40932 W !!,"Checking file 409.32 one last time.",! "RTN","SDWLCU5",28,0) N INERROR S INERROR="" S SDWLSC=0 F S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC D UPDINS(SDWLSC,.INERROR) "RTN","SDWLCU5",29,0) Q:INERROR=1 "RTN","SDWLCU5",30,0) N DIK S DIK="^SDWL(409.32," D IXALL^DIK "RTN","SDWLCU5",31,0) W !!,"Checking file 409.3 one last time.",! "RTN","SDWLCU5",32,0) S SDWLERR="" "RTN","SDWLCU5",33,0) S SDWLDA=0,TAG="CHK" F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D Q:SDWLERR=1 "RTN","SDWLCU5",34,0) .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5) "RTN","SDWLCU5",35,0) .Q:'SDWLTY!'SDWLINST "RTN","SDWLCU5",36,0) .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI "RTN","SDWLCU5",37,0) .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG "RTN","SDWLCU5",38,0) W !,"Done." "RTN","SDWLCU5",39,0) Q "RTN","SDWLCU5",40,0) UPDINS(SDWLSC,INERROR) ; update 409.32 and the related entroes in 409.3 "RTN","SDWLCU5",41,0) N SDWLINS S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") ; current set up IN 409.32 "RTN","SDWLCU5",42,0) ;check set up in file 44 "RTN","SDWLCU5",43,0) ;get clinic "RTN","SDWLCU5",44,0) N CL,CLN S CL=$$GET1^DIQ(409.32,SDWLSC_",",.01,"I"),CLN=$$GET1^DIQ(44,CL_",",.01) "RTN","SDWLCU5",45,0) N STR,SDWMES S SDWMES="",STR=$$CLIN^SDWLPE(CL) "RTN","SDWLCU5",46,0) S SDWMES=SDWMES_$P(STR,U,6) "RTN","SDWLCU5",47,0) I $P(STR,U,5)="L" S SDWMES=SDWMES_" - Local Institution assigned to clinic. " "RTN","SDWLCU5",48,0) I SDWMES'="" D Q "RTN","SDWLCU5",49,0) .W !!," ** Incorrect Setting up of Clinic "_CLN_" ("_CL_")"_": **" "RTN","SDWLCU5",50,0) .W !!,SDWMES "RTN","SDWLCU5",51,0) .W !!,"INSTALLATION WILL CONTINUE WITHOUT UPDATING THIS ENTRY." "RTN","SDWLCU5",52,0) .W !!,"AFTER INSTALLATION CORRECT THE CLINIC SETUP AND THEN",!," RUN OPTION SD WAIT LIST CLEANUP." "RTN","SDWLCU5",53,0) .S:INERROR="" INERROR=1 Q "RTN","SDWLCU5",54,0) I +STR'=SDWLINS W !!,"Clinic "_CLN_" ("_CL_")"_"does not have the same Institution as EWL set up." D "RTN","SDWLCU5",55,0) .W !!,"EWL Clinic INSTITUTION: ",$$GET1^DIQ(4,SDWLINS_",",.01)_" - "_$$GET1^DIQ(4,SDWLINS_",",99) "RTN","SDWLCU5",56,0) .W !,"Clinic INSTITUTION: ",$P(STR,U,3)_" - "_$P(STR,U,2) "RTN","SDWLCU5",57,0) .W !!,"EWL set up will be updated with the Clinic from the Hospital Location file," "RTN","SDWLCU5",58,0) .W !,"and the related open EWL entries will be updated as well." "RTN","SDWLCU5",59,0) .N DIE,DR,DA S DR=".02////^S X=+STR",DIE="^SDWL(409.32,",DA=SDWLSC "RTN","SDWLCU5",60,0) .L +^SDWL(409.32,DA):0 I '$T W !?5,"Another user is editing this entry. try later." Q "RTN","SDWLCU5",61,0) .D ^DIE L -^SDWL(409.32,DA) "RTN","SDWLCU5",62,0) .;loop to update EWL entries in FILE 409.3 if any "RTN","SDWLCU5",63,0) .N SCL,DA,DR,CNT S SCL="",CNT=0 F S SCL=$O(^SDWL(409.3,"SC",CL,SCL)) Q:SCL'>0 D "RTN","SDWLCU5",64,0) ..I '$D(^SDWL(409.3,SCL,0)) K ^SDWL(409.3,"SC",CL,SCL) Q "RTN","SDWLCU5",65,0) ..S DR="2////^S X=+STR",DIE="^SDWL(409.3,",DA=SCL "RTN","SDWLCU5",66,0) ..L +^SDWL(409.3,SCL):0 I '$T W !?5,"Another user is editing this entry. try later." Q "RTN","SDWLCU5",67,0) ..D ^DIE L -^SDWL(409.3,SCL) S CNT=CNT+1 "RTN","SDWLCU5",68,0) .I CNT>0 W !,CNT_" EWL entries for clinic "_CLN_" updated." "RTN","SDWLCU5",69,0) N DA I $$GET1^DIQ(409.32,SDWLSC_",",3,"I")="" I $$GET1^DIQ(409.32,SDWLSC_",",1,"I")'>0 D "RTN","SDWLCU5",70,0) .S DA=SDWLSC L +^SDWL(409.32,SDWLSC):0 I '$T W !?5,"Another user is editing this entry. try later." Q "RTN","SDWLCU5",71,0) .S DR="1////^S X=DT;2////^S X=DUZ",DIE="^SDWL(409.32," ;enter activation date and user "RTN","SDWLCU5",72,0) .D ^DIE L -^SDWL(409.32,SDWLSC) "RTN","SDWLCU5",73,0) .W !,"EWL Clinic entry for "_CLN_" updated with today's activation date." "RTN","SDWLCU5",74,0) Q "RTN","SDWLCU5",75,0) CHK1 ;CHECK FOR INSTITUTION VALIDILITY "RTN","SDWLCU5",76,0) S SDWLERR=0 "RTN","SDWLCU5",77,0) I SDWLTY=1 S SDWLI=0 F S SDWLI=$O(^SCTM(404.51,"AINST",SDWLI)) Q:SDWLI="" I $D(^DIC(4,SDWLI)) S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLI)="",^TMP($J,"SDWLCU5",$J,"B",SDWLI)="" "RTN","SDWLCU5",78,0) I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q "RTN","SDWLCU5",79,0) K ^TMP($J,"SDWLCU5",$J,"B") "RTN","SDWLCU5",80,0) I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q "RTN","SDWLCU5",81,0) I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q "RTN","SDWLCU5",82,0) W !,"Please select a valid Institution for this record from the following list for",! "RTN","SDWLCU5",83,0) D DIS "RTN","SDWLCU5",84,0) S C=0,SDWLI="" F S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1 D "RTN","SDWLCU5",85,0) .F S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI="" W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C "RTN","SDWLCU5",86,0) CHK10 W ! S DIR(0)="NO^1:"_CS D ^DIR "RTN","SDWLCU5",87,0) I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q "RTN","SDWLCU5",88,0) S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) "RTN","SDWLCU5",89,0) CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") "RTN","SDWLCU5",90,0) S TAG="CHK" "RTN","SDWLCU5",91,0) Q "RTN","SDWLCU5",92,0) CHK3 ; "RTN","SDWLCU5",93,0) S SDWLERR="" "RTN","SDWLCU5",94,0) S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8) "RTN","SDWLCU5",95,0) Q:'SDWLI!'$D(^SDWL(409.31,SDWLI)) "RTN","SDWLCU5",96,0) I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D Q:SDWLERR=1 "RTN","SDWLCU5",97,0) .S SDWLIX="",C=0 F S SDWLIX=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIX)) Q:SDWLIX="" S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLIX)="",^TMP($J,"SDWLCU5",$J,"B",SDWLIX)="" "RTN","SDWLCU5",98,0) .I 'C N SITE S SITE=+$$SITE^VASITE(,) S SDWLINSN=$S(SITE>0:SITE,1:""),Y=1 D CHE3 Q "RTN","SDWLCU5",99,0) .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q "RTN","SDWLCU5",100,0) .W !,"Please select a valid Institution for this record from the following list for",! "RTN","SDWLCU5",101,0) .D DIS "RTN","SDWLCU5",102,0) .S C=0,SDWLIZ=0 F S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ="" D "RTN","SDWLCU5",103,0) ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ)) "RTN","SDWLCU5",104,0) ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01) "RTN","SDWLCU5",105,0) .W ! S DIR(0)="NO^1:"_C D ^DIR "RTN","SDWLCU5",106,0) .I $D(DUOUT)!(Y="") S SDWLERR=1 Q "RTN","SDWLCU5",107,0) .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) "RTN","SDWLCU5",108,0) .D CHE3 "RTN","SDWLCU5",109,0) Q "RTN","SDWLCU5",110,0) CHE3 ; "RTN","SDWLCU5",111,0) G CHK3:Y<0 "RTN","SDWLCU5",112,0) S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") "RTN","SDWLCU5",113,0) S TAG="CHK" "RTN","SDWLCU5",114,0) Q "RTN","SDWLCU5",115,0) CHK4 ; "RTN","SDWLCU5",116,0) S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9) "RTN","SDWLCU5",117,0) Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0)) "RTN","SDWLCU5",118,0) I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D "RTN","SDWLCU5",119,0) .D DIS "RTN","SDWLCU5",120,0) .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") "RTN","SDWLCU5",121,0) Q "RTN","SDWLCU5",122,0) CHK2 ; "RTN","SDWLCU5",123,0) S SDWLPO=$P($G(^SDWL(409.3,SDWLDA,0)),U,7),SDWLTM=$P($G(^SCTM(404.57,SDWLPO,0)),U,2),SDWLINSN=$P($G(^SCTM(404.51,SDWLTM,0)),U,7) "RTN","SDWLCU5",124,0) I SDWLINST'=SDWLINSN D "RTN","SDWLCU5",125,0) .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") "RTN","SDWLCU5",126,0) S TAG="CHK" "RTN","SDWLCU5",127,0) Q "RTN","SDWLCU5",128,0) DIS ;display record "RTN","SDWLCU5",129,0) S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E") "RTN","SDWLCU5",130,0) S SSN=$$GET1^DIQ(2,NN_",",.09) "RTN","SDWLCU5",131,0) W !,"Record#: ",SDWLDA," Patient: ",NAME," (",SSN,")",!! "RTN","SDWLCU5",132,0) Q "RTN","SDWLCU5",133,0) GETINS ;Get institution "RTN","SDWLCU5",134,0) N DIR "RTN","SDWLCU5",135,0) S DIR("A")="Select Institution: " "RTN","SDWLCU5",136,0) S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR "RTN","SDWLCU5",137,0) I X["^" S SDWLERR=1 Q "RTN","SDWLCU5",138,0) I Y<1 W *7,"Invalid Entry" G GETINS "RTN","SDWLCU5",139,0) S SDWLINSN=+Y "RTN","SDWLCU5",140,0) Q "RTN","SDWLCU6") 0^15^B10460494^B10350160 "RTN","SDWLCU6",1,0) SDWLCU6 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP - print ;2/15/05 ; Compiled August 20, 2007 15:12:20 "RTN","SDWLCU6",2,0) ;;5.3;scheduling;**427,491**;AUG 13 1993;Build 53 "RTN","SDWLCU6",3,0) N XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1 "RTN","SDWLCU6",4,0) S (IEN,PAT)="",(CC,SDWLPG,SDWLTP)=0,U="^",END="" "RTN","SDWLCU6",5,0) D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y "RTN","SDWLCU6",6,0) D HD "RTN","SDWLCU6",7,0) F S PAT=$O(^SDWL(409.3,"B",PAT)) Q:PAT="" D Q:END "RTN","SDWLCU6",8,0) .S IEN="" F S IEN=$O(^SDWL(409.3,"B",PAT,IEN)) Q:IEN="" D Q:END "RTN","SDWLCU6",9,0) ..S SDWLX=$G(^SDWL(409.3,IEN,0)),XFLG="",XFL=1,SDWLWD="",SDWLTP1="" "RTN","SDWLCU6",10,0) ..F I=3,5,XFL S XDATA=$P(SDWLX,U,I) S:I=5&XDATA XFL=XDATA+5 S:'XDATA XFLG=XFLG_I I I=5,XFL=1 D FIX "RTN","SDWLCU6",11,0) ..I XFLG D "RTN","SDWLCU6",12,0) ...D HD:$Y+5>IOSL Q:END "RTN","SDWLCU6",13,0) ...S NN="",NAME="" S NN=$P($G(^SDWL(409.3,IEN,0)),"^",1),NAME=$$GET1^DIQ(2,NN_",",.01,"E") "RTN","SDWLCU6",14,0) ...S SDWLAPTD=$P(SDWLX,U,16) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y "RTN","SDWLCU6",15,0) ...W !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$P(SDWLX,U,17),?58 "RTN","SDWLCU6",16,0) ...S XFL="" F I=1:1:3 Q:$E(XFLG,I)="" S XFL=XFL_$S(XFL'="":",",1:"")_$P("::INST::Type:Team:Postn:Srv/Spec:Clinic",":",$E(XFLG,I)) "RTN","SDWLCU6",17,0) ...W XFL W:SDWLTP1'="" "/++" "RTN","SDWLCU6",18,0) ...W:SDWLWD'="" !,?5,SDWLWD "RTN","SDWLCU6",19,0) ...S CC=CC+1 "RTN","SDWLCU6",20,0) Q:END "RTN","SDWLCU6",21,0) IF CC>.5 W !!,"TOTAL null field error EWL entries: "_CC "RTN","SDWLCU6",22,0) I SDWLTP>.5 W !!,"++ Missing Wait List Type and corresponding field entry (TEAM,POSITION,",!," SERVICE/SPECIALTY,CLINIC). Correct corresponding field entries",!," and running report again will correct Wait List Type field" "RTN","SDWLCU6",23,0) D CLINIC "RTN","SDWLCU6",24,0) W !!,"** End of Report **" "RTN","SDWLCU6",25,0) Q "RTN","SDWLCU6",26,0) CLINIC ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message "RTN","SDWLCU6",27,0) S INST="",CLINIC=0,CC=0 "RTN","SDWLCU6",28,0) F S CLINIC=$O(^SDWL(409.32,CLINIC)) Q:'CLINIC D "RTN","SDWLCU6",29,0) . N CL,INSTST S CL=+$G(^SDWL(409.32,CLINIC,0)) Q:CL'>0 "RTN","SDWLCU6",30,0) . S INSTST=$$CLIN^SDWLPE(CL) "RTN","SDWLCU6",31,0) . I $P(INSTST,U,6)'="" W !,*7,$P(INSTST,U,6) D "RTN","SDWLCU6",32,0) .. S CC=CC+1 "RTN","SDWLCU6",33,0) .. I CC=1 W !!!,"The following clinics need to have the institution updated in file 44:",!! "RTN","SDWLCU6",34,0) .. W !,?20,$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",.01) "RTN","SDWLCU6",35,0) Q "RTN","SDWLCU6",36,0) FIX ;fix corrupted Wait List Type piece 5 "RTN","SDWLCU6",37,0) S XFL1=0,SDWLTP1="" "RTN","SDWLCU6",38,0) F J=6:1:9 S XDATA=$P(SDWLX,U,J) S:XDATA'="" XFL1=J "RTN","SDWLCU6",39,0) I 'XFL1 S SDWLTP=SDWLTP+1,SDWLTP1="++" Q "RTN","SDWLCU6",40,0) I XFL'=1,XFL=XFL1 Q "RTN","SDWLCU6",41,0) S $P(SDWLX,U,5)=XFL1-5,XFL=XFL1,^SDWL(409.3,IEN,0)=SDWLX "RTN","SDWLCU6",42,0) S SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$P("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")" "RTN","SDWLCU6",43,0) Q "RTN","SDWLCU6",44,0) HD ;HDR "RTN","SDWLCU6",45,0) I SDWLPG>0,$E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:END "RTN","SDWLCU6",46,0) S SDWLPG=SDWLPG+1 W:SDWLPG'=1 @IOF "RTN","SDWLCU6",47,0) W !,?15,"Wait List Key Field 'NULL' Report" "RTN","SDWLCU6",48,0) S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD,?72,"Page: ",SDWLPG "RTN","SDWLCU6",49,0) W !!,"STATION: "_+$$SITE^VASITE(,) "RTN","SDWLCU6",50,0) W !!,"IEN Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields" "RTN","SDWLCU6",51,0) Q "RTN","SDWLPE") 0^12^B27362076^B17821077 "RTN","SDWLPE",1,0) SDWLPE ;IOFO BAY PINES/TEH - WAIT LIST - PARAMETER WAIT LIST ENTER/EDIT ;20 Aug 2002 ; Compiled April 22, 2008 14:13:00 "RTN","SDWLPE",2,0) ;;5.3;scheduling;**263,280,288,397,491**;AUG 13 1993;Build 53 "RTN","SDWLPE",3,0) ; "RTN","SDWLPE",4,0) ;SD/491 - identify clinic institution through DIVISION ---> INSTITUTION path "RTN","SDWLPE",5,0) EN ; "RTN","SDWLPE",6,0) ;OPTION HEADER "RTN","SDWLPE",7,0) ; "RTN","SDWLPE",8,0) D HD "RTN","SDWLPE",9,0) ; "RTN","SDWLPE",10,0) ;SELECT FILE TO EDIT "RTN","SDWLPE",11,0) ; "RTN","SDWLPE",12,0) EN1 D SEL G END:X["^",END:X="" "RTN","SDWLPE",13,0) ; "RTN","SDWLPE",14,0) ;EDIT PARAMETER FILE "RTN","SDWLPE",15,0) ; "RTN","SDWLPE",16,0) D EDIT G EN:'$D(Y) "RTN","SDWLPE",17,0) G END "RTN","SDWLPE",18,0) Q "RTN","SDWLPE",19,0) ; "RTN","SDWLPE",20,0) SEL ;SELECT PARAMETER FILE "RTN","SDWLPE",21,0) S DIR(0)="SO^1:Wait List Service/Specialty File;2:Wait List Clinic Location" "RTN","SDWLPE",22,0) S DIR("L",1)="Select one of the following:" "RTN","SDWLPE",23,0) S DIR("L",2)="" "RTN","SDWLPE",24,0) S DIR("L",3)=" 1. Wait List Service/Specialty (409.31)" "RTN","SDWLPE",25,0) S DIR("L")=" 2. Wait List Clinic Location (409.32)" "RTN","SDWLPE",26,0) D ^DIR S SDWLF=X "RTN","SDWLPE",27,0) K DIR,DILN,DINDEX "RTN","SDWLPE",28,0) Q "RTN","SDWLPE",29,0) EDIT ;EDIT FILE PARAMETERS "RTN","SDWLPE",30,0) I SDWLF=1 D SB1 Q:$D(DUOUT) "RTN","SDWLPE",31,0) I SDWLF=2 D SB2 Q:$D(DUOUT) "RTN","SDWLPE",32,0) Q "RTN","SDWLPE",33,0) SB1 S DIC(0)="AEQMZ",DIC("A")="Select DSS ID: ",DIC="^DIC(40.7,",DIC("S")="I '$P(^DIC(40.7,+Y,0),U,3)" "RTN","SDWLPE",34,0) D ^DIC "RTN","SDWLPE",35,0) I X["^" I $D(DA),'$D(^SDWL(409.31,DA,"I")) S DIK="^SDWL(409.31," D ^DIK S DUOUT=1 Q "RTN","SDWLPE",36,0) Q:Y<0 Q:$D(DUOUT) S SDWLDSS=+Y "RTN","SDWLPE",37,0) I '$D(^SDWL(409.31,"B",SDWLDSS)) D "RTN","SDWLPE",38,0) .S DIC(0)="LX",X=SDWLDSS,DIC="^SDWL(409.31," K DO D FILE^DICN "RTN","SDWLPE",39,0) S DA=$O(^SDWL(409.31,"B",SDWLDSS,"")) "RTN","SDWLPE",40,0) SB1A S DIR(0)="PAO^4:EMZ" D ^DIR "RTN","SDWLPE",41,0) I X="" W *7," Required" G SB1A "RTN","SDWLPE",42,0) I X["^" D:'$D(^SDWL(409.31,DA,"I")) S DUOUT=1 Q "RTN","SDWLPE",43,0) .S DIK="^SDWL(409.31," D ^DIK "RTN","SDWLPE",44,0) S X=$$GET1^DIQ(4,+Y_",",11) "RTN","SDWLPE",45,0) I X'["N"!'$$TF^XUAF4(+Y) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB1A "RTN","SDWLPE",46,0) I '$D(^SDWL(409.31,DA,"I","B",+Y)) D "RTN","SDWLPE",47,0) .S DA(1)=DA,DIC="^SDWL(409.31,"_DA(1)_","_"""I"""_",",DIC("P")=409.311,X=+Y K D0 D FILE^DICN I +Y S DA=+Y "RTN","SDWLPE",48,0) I $D(^SDWL(409.31,DA,"I","B",+Y)) S DA(1)=DA,DA=$O(^(+Y,0)) "RTN","SDWLPE",49,0) K DIC,DIE,DIR,DR "RTN","SDWLPE",50,0) W ! S DR="1;3",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE "RTN","SDWLPE",51,0) I $P(^SDWL(409.31,DA(1),"I",DA,0),U,2)="" D "RTN","SDWLPE",52,0) .W *7,!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted." "RTN","SDWLPE",53,0) .S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK I '$P(^SDWL(409.31,DA(1),"I",0),U,3) D "RTN","SDWLPE",54,0) ..S DIK="^SDWL(409.31,",DA=DA(1) D ^DIK "RTN","SDWLPE",55,0) K DA,DA(1),SDWLDSS,DIC,DR,DIE,DI,DIEDA,DIG,DIH,DIIENS,DIR,DIU,DIV "RTN","SDWLPE",56,0) Q "RTN","SDWLPE",57,0) SB2 N STR,INST,DIC,SDWLSC,SDWLSTOP S SDWLSTOP=0 "RTN","SDWLPE",58,0) W ! S DIC(0)="AEMNZ",DIC("A")="Select Clinic: ",DIC=44 "RTN","SDWLPE",59,0) S DIC("S")="S SDWLX=$G(^SC(+Y,0)),SDWLY=$G(^(""I"")) I $P(SDWLX,U,3)=""C"",$P(SDWLY,U,1)'>$P(SDWLY,U,2)" "RTN","SDWLPE",60,0) S DIC("W")="S STR=$$CLIN^SDWLPE(+Y) I STR W ?50,""- "",$E($P(STR,U,3),1,25),""("",$P(STR,U,2),"")""" "RTN","SDWLPE",61,0) D ^DIC I Y<1 K DIC,DA Q "RTN","SDWLPE",62,0) Q:$D(DUOUT) S SDWLSC=+Y S INST=+STR ;$$CLIN(SDWLSC) "RTN","SDWLPE",63,0) I $P(STR,U,6)'="" W !,*7,$P(STR,U,6) G SB2 "RTN","SDWLPE",64,0) N SDANEW S SDANEW="" "RTN","SDWLPE",65,0) I '$D(^SDWL(409.32,"B",SDWLSC)) D "RTN","SDWLPE",66,0) .S DIC(0)="LX",X=SDWLSC,DIC="^SDWL(409.32," D FILE^DICN "RTN","SDWLPE",67,0) .N DA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")) S SDANEW=DA "RTN","SDWLPE",68,0) .S DIE="^SDWL(409.32,",DR=".02////^S X=INST" D ^DIE "RTN","SDWLPE",69,0) N DA,SDA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")),SDA=DA "RTN","SDWLPE",70,0) S DR="1",DIE="^SDWL(409.32," D ^DIE "RTN","SDWLPE",71,0) I SDANEW,'X D D ESB2 H 1 G SB2 "RTN","SDWLPE",72,0) .W *7,!!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted." "RTN","SDWLPE",73,0) .S DA=SDANEW S DIK="^SDWL(409.32," D ^DIK "RTN","SDWLPE",74,0) I X S DR="2////^S X=DUZ" D ^DIE "RTN","SDWLPE",75,0) N DIC "RTN","SDWLPE",76,0) S SDWLSCN=$P($G(^SDWL(409.32,SDA,0)),U,1) D Q:SDWLSTOP "RTN","SDWLPE",77,0) .I $D(^SDWL(409.3,"SC",SDWLSCN)) D "RTN","SDWLPE",78,0) ..S SDWLN="",SDWLCNT=0 F S SDWLN=$O(^SDWL(409.3,"SC",SDWLSCN,SDWLN)) Q:SDWLN="" D "RTN","SDWLPE",79,0) ...S X=$G(^SDWL(409.3,SDWLN,0)) I '$D(^SDWL(409.3,SDWLN,"DIS")) S SDWLCNT=SDWLCNT+1,^TMP("SDWLPE",$J,"DIS",SDWLN,SDWLCNT)=X,SDWLSTOP=1 "RTN","SDWLPE",80,0) ..I SDWLSTOP W !,"This Clinic has Patients on the Wait List and can not be inactivated." H 2 Q "RTN","SDWLPE",81,0) .S DR="4////^S X=DUZ" D ^DIE "RTN","SDWLPE",82,0) S DR="3",DIE="^SDWL(409.32," D ^DIE "RTN","SDWLPE",83,0) ESB2 ; "RTN","SDWLPE",84,0) K DR,DIE,DIC,Y,X,SDWLY,DIC(0),DO,DA,DI,DIW,SDWLX,SDWLSCN,SDWLF "RTN","SDWLPE",85,0) Q "RTN","SDWLPE",86,0) SWT ;SWITCH FOR INACTIVATION OF PARAMETER FILE "RTN","SDWLPE",87,0) Q "RTN","SDWLPE",88,0) HD ;HEADER "RTN","SDWLPE",89,0) W:$D(IOF) @IOF W !!,?80-$L("Wait List Parameter Enter/Edit")\2,"Wait List Parameter Enter/Edit",! "RTN","SDWLPE",90,0) W !,?80-$L("------------------------------")\2,"------------------------------",! "RTN","SDWLPE",91,0) END K SDWLSTOP,DIR,DIC,DR,DIK,SDWLX,SDWLSCN,SDWLF,SDWLY,SDWLSC,SDWLN,SDWLCNT,SDWLDSS,DUOUT,X,Y "RTN","SDWLPE",92,0) Q "RTN","SDWLPE",93,0) CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path. "RTN","SDWLPE",94,0) ; function to return: "RTN","SDWLPE",95,0) ; 1 2 3 4 5 6 7 "RTN","SDWLPE",96,0) ; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ INST Name _U_ DIV Pointer to ^DG(40.8 _U_N/L_U_Message_U_TYPE "RTN","SDWLPE",97,0) ; ( INST^STA NUM^SNAM^DIV^N/L^MESS^TYPE ) "RTN","SDWLPE",98,0) ; N/L - N -National/L -Local "RTN","SDWLPE",99,0) ; TYPE - type of entry in file # 44 (field #2) "RTN","SDWLPE",100,0) ; C:CLINIC "RTN","SDWLPE",101,0) ; M:MODULE "RTN","SDWLPE",102,0) ; W:WARD "RTN","SDWLPE",103,0) ; Z:OTHER LOCATION "RTN","SDWLPE",104,0) ; N:NON-CLINIC STOP "RTN","SDWLPE",105,0) ; F:FILE AREA "RTN","SDWLPE",106,0) ; I:IMAGING "RTN","SDWLPE",107,0) ; OR:OPERATING ROOM "RTN","SDWLPE",108,0) ; "RTN","SDWLPE",109,0) ; with optional Message: "RTN","SDWLPE",110,0) ; "RTN","SDWLPE",111,0) ; if STA="" "RTN","SDWLPE",112,0) ; - INST^^SNAM^DIV^N/L^' - No Station Number on file' ^ TYPE "RTN","SDWLPE",113,0) ; or "RTN","SDWLPE",114,0) ; - 0^^^DIV^^' - No Institution has been identified '^ TYPE "RTN","SDWLPE",115,0) ; - 0^^^-1^^' - No Division has been identified' ^ TYPE "RTN","SDWLPE",116,0) ; "RTN","SDWLPE",117,0) ; if entry is inactivated: "RTN","SDWLPE",118,0) ; "RTN","SDWLPE",119,0) ; - INST^^SNAM^DIV^N/L^' - Inactive treating medical facility' ^ TYPE "RTN","SDWLPE",120,0) ; - -1^^^^^' - No clinic on file' ^ "RTN","SDWLPE",121,0) ; "RTN","SDWLPE",122,0) I +CL=0!'$D(^SC(+CL)) Q -1_"^^^^^ - No clinic on file^" "RTN","SDWLPE",123,0) N SDWMES,STN,DIV,INS,SNL,STR,SNAM S SDWMES="",STN="" "RTN","SDWLPE",124,0) N TYPE S TYPE=$$GET1^DIQ(44,CL_",",2,"E") "RTN","SDWLPE",125,0) S DIV=+$$GET1^DIQ(44,CL_",",3.5,"I") "RTN","SDWLPE",126,0) I DIV=0 S SDWMES=" - No Division has been identified" Q 0_"^^^"_-1_"^^"_SDWMES_U_TYPE "RTN","SDWLPE",127,0) S INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I") "RTN","SDWLPE",128,0) I INS=0 S SDWMES=" - No Institution has been identified" Q 0_"^^^"_DIV_"^^"_SDWMES_U_TYPE "RTN","SDWLPE",129,0) E S STR=$$NS^XUAF4(INS),STN=$P(STR,U,2),SNAM=$P(STR,U) ;station number and name "RTN","SDWLPE",130,0) I STN="" S SDWMES=" - No Station Number on file" "RTN","SDWLPE",131,0) I '$$TF^XUAF4(INS) S SDWMES=SDWMES_" - Inactive treating medical facility" "RTN","SDWLPE",132,0) S SNL=$$GET1^DIQ(4,INS_",",11,"I") "RTN","SDWLPE",133,0) Q INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES_U_TYPE "RTN","SDWLREB") 0^13^B72917718^B76814897 "RTN","SDWLREB",1,0) SDWLREB ;BP/ESW - EWL matched with Canceled and Rebooked Appointment by Clinic ; 11/16/05 1:16pm ; Compiled October 25, 2006 17:29:46 "RTN","SDWLREB",2,0) ;;5.3;Scheduling;**467,491**;Aug 13, 1993;Build 53 "RTN","SDWLREB",3,0) ; "RTN","SDWLREB",4,0) ;SD*5.3*467 - Match canceled appointments in EWL entries "RTN","SDWLREB",5,0) ; "RTN","SDWLREB",6,0) Q "RTN","SDWLREB",7,0) REBOOK(DFN,SD,SC,RBFLG,SDTRB,SDCAN) ; rebook section "RTN","SDWLREB",8,0) ;create appt TMP to check for rebooking "RTN","SDWLREB",9,0) ;SD - appt date/time "RTN","SDWLREB",10,0) ;SC - Hospital Location IEN "RTN","SDWLREB",11,0) ;called by reference: "RTN","SDWLREB",12,0) ; RBFLG - cancellation status from Appointment Multiple "RTN","SDWLREB",13,0) ; Only if RBFLG="CCR" - canceled by clinic, rebooked "RTN","SDWLREB",14,0) ; SDTRB - asked for scheduled Date/Time of Rebooked Appointment "RTN","SDWLREB",15,0) ; SDCAN - asked for cancellation date/time "RTN","SDWLREB",16,0) N SDARR,SCNT "RTN","SDWLREB",17,0) S RBFLG=0,SDTRB="",SDCAN="NONE" ;initiate if not 'good' appointment "RTN","SDWLREB",18,0) S SDARR(1)=SD_";"_SD "RTN","SDWLREB",19,0) S SDARR(2)=SC "RTN","SDWLREB",20,0) S SDARR(4)=DFN "RTN","SDWLREB",21,0) S SDARR("FLDS")="1;2;3;24;25" "RTN","SDWLREB",22,0) N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D "RTN","SDWLREB",23,0) .N SDINST,SDFAC,SDINSTE "RTN","SDWLREB",24,0) .Q:'$D(^TMP($J,"SDAMA301",DFN)) "RTN","SDWLREB",25,0) .N SDSTR S SDSTR=^TMP($J,"SDAMA301",DFN,SC,SD) "RTN","SDWLREB",26,0) .N SDSTAT S SDSTAT=$P(SDSTR,U,3) "RTN","SDWLREB",27,0) .K ^TMP($J,"SDAMA301",DFN,SC,SD) "RTN","SDWLREB",28,0) .S RBFLG=$P(SDSTAT,";") "RTN","SDWLREB",29,0) .S SDTRB=$P(SDSTR,U,24) "RTN","SDWLREB",30,0) .S SDCAN=$P(SDSTR,U,25) "RTN","SDWLREB",31,0) Q "RTN","SDWLREB",32,0) DISREB(DFN,SDTRB,SC) ;DISPOSITION REBOOK OR NOT "RTN","SDWLREB",33,0) ; DFN - IEN of file #2 (Patient) "RTN","SDWLREB",34,0) ; SDTRB - Scheduled Date/Time of Rebooked Appt "RTN","SDWLREB",35,0) ; SC - Clinic IEN "RTN","SDWLREB",36,0) ; Temporary ^TMP($J,"APPT" will be created with rebooked appt data "RTN","SDWLREB",37,0) N SDARR,SCNT,SDDIV "RTN","SDWLREB",38,0) S SDDIV="" "RTN","SDWLREB",39,0) S SDARR(1)=SDTRB_";"_SDTRB "RTN","SDWLREB",40,0) S SDARR(2)=SC "RTN","SDWLREB",41,0) S SDARR(4)=DFN "RTN","SDWLREB",42,0) S SDARR("FLDS")="1;2;3;4;10;13;14" "RTN","SDWLREB",43,0) N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D "RTN","SDWLREB",44,0) .N SDINST,SDFAC,SDINSTE "RTN","SDWLREB",45,0) .Q:'$D(^TMP($J,"SDAMA301",DFN)) "RTN","SDWLREB",46,0) .K ^TMP($J,"APPT") S SCNT=1 "RTN","SDWLREB",47,0) .S ^TMP($J,"APPT",SCNT)=^TMP($J,"SDAMA301",DFN,SC,SDTRB) "RTN","SDWLREB",48,0) .N SFAC S SFAC=$$CLIN^SDWLPE(SC) D ;SD/491 "RTN","SDWLREB",49,0) ..S SDINST=+SFAC,SDINSTE=$P(SFAC,U,3),SDFAC=$P(SFAC,U,2) "RTN","SDWLREB",50,0) .S $P(^TMP($J,"APPT",SCNT),"^",15)=SDINST_";"_SDINSTE "RTN","SDWLREB",51,0) .S $P(^TMP($J,"APPT",SCNT),"^",16)=SDFAC "RTN","SDWLREB",52,0) .K ^TMP($J,"SDAMA301",DFN,SC,SDTRB) "RTN","SDWLREB",53,0) Q "RTN","SDWLREB",54,0) OPENEWL(DFN,SDT,SC,SDREB,CEWL) ; SD*5.3*467 Open EWL entry if closed with appointment being canceled "RTN","SDWLREB",55,0) ;SDT - appointment date/time "RTN","SDWLREB",56,0) ;SC - appointment clinic IEN "RTN","SDWLREB",57,0) ;SDREB - REBOOKING FLAG: 1 - cancel & rebook "RTN","SDWLREB",58,0) ; 0 - cancel only "RTN","SDWLREB",59,0) ;CEWL - counter, optionally passed by reference with initial value=0 "RTN","SDWLREB",60,0) N DH,IEN,STATUS,CLINIC,WLAPPT,WLSTAT,SDNAM,SDAPPT,SSN,SCN "RTN","SDWLREB",61,0) K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL") "RTN","SDWLREB",62,0) I '$D(CEWL) D "RTN","SDWLREB",63,0) .I $D(^TMP("SDWLREB",$J)) S CEWL=$O(^TMP("SDWLREB",$J,""),-1) "RTN","SDWLREB",64,0) .E S CEWL=0 "RTN","SDWLREB",65,0) S IEN="" F S IEN=$O(^SDWL(409.3,"B",DFN,IEN)) Q:IEN<1 D "RTN","SDWLREB",66,0) .S STATUS="" S STATUS=$$GET1^DIQ(409.3,IEN_",",23,"I") IF STATUS="C" D "RTN","SDWLREB",67,0) ..IF $G(^SDWL(409.3,IEN,"SDAPT")) D "RTN","SDWLREB",68,0) ...S CLINIC=$$GET1^DIQ(409.3,IEN_",",13.2,"I"),WLAPPT=$$GET1^DIQ(409.3,IEN_",",13,"I") "RTN","SDWLREB",69,0) ...IF CLINIC=SC&(WLAPPT=SDT) S WLSTAT=$$GET1^DIQ(409.3,IEN_",",21,"I") I WLSTAT="SA" D "RTN","SDWLREB",70,0) ....N Y S Y=WLAPPT D DD^%DT S SDAPPT=Y "RTN","SDWLREB",71,0) ....S SCN=$$GET1^DIQ(44,SC_",",.01),SCN=$E(SCN,1,20) "RTN","SDWLREB",72,0) ....S SDNAM=$$GET1^DIQ(2,DFN_",",.01,"I"),SDNAM=$E(SDNAM,1,25),SSN=$$GET1^DIQ(2,DFN_",",.09,"I") "RTN","SDWLREB",73,0) ....S SDFORM=$$FORM^SDFORM(SDNAM,23,SSN,12,SCN,24,SDAPPT,20) "RTN","SDWLREB",74,0) ....S CEWL=CEWL+1 S ^TMP("SDWLREB",$J,CEWL)=SDFORM "RTN","SDWLREB",75,0) ....N DIE,DA,DR "RTN","SDWLREB",76,0) ....S DIE="^SDWL(409.3,",DA=IEN,DR="23////^S X=""O""" D ^DIE "RTN","SDWLREB",77,0) ....S DR="13.8////^S X=""CC""" D ^DIE "RTN","SDWLREB",78,0) ....S DR="29////^S X=""CA""" D ^DIE "RTN","SDWLREB",79,0) ....S DR="19///@" D ^DIE "RTN","SDWLREB",80,0) ....S DR="20///@" D ^DIE "RTN","SDWLREB",81,0) ....S DR="21///@" D ^DIE "RTN","SDWLREB",82,0) ....S DR="13///@;13.1////@;13.2///@;13.3///@;13.4///@;13.5///@;13.6///@;13.8///@;13.7///@" D ^DIE "RTN","SDWLREB",83,0) ....I $D(^TMP("SDWLREB",$J)) I SDREB D ASKDISP(IEN) "RTN","SDWLREB",84,0) I '$D(^TMP($J,"SDWLPL")) Q ; no closed EWL related entry "RTN","SDWLREB",85,0) I SDREB D DISP "RTN","SDWLREB",86,0) Q "RTN","SDWLREB",87,0) MESS ; SD*5.3*467 - send message with a list of opened EWL entries because of canceled appointments "RTN","SDWLREB",88,0) S ^TMP("SDWLREB",$J,.01)="This message displays patients that had their EWL entry opened because of " "RTN","SDWLREB",89,0) S ^TMP("SDWLREB",$J,.02)="their matching appointment being now 'CANCELED BY CLINIC'. Some of those " "RTN","SDWLREB",90,0) S ^TMP("SDWLREB",$J,.03)="entries may be already closed again if new appointments were scheduled and " "RTN","SDWLREB",91,0) S ^TMP("SDWLREB",$J,.04)="matched with those EWL entries. You may use 'SD WAIT LIST REOPEN ENTRIES' " "RTN","SDWLREB",92,0) S ^TMP("SDWLREB",$J,.05)="to run report identifying the related EWL entries." "RTN","SDWLREB",93,0) N SDFORM S SDFORM=$$FORM^SDFORM("PATIENT NAME",23,"SSN",12,"CLINIC",24,"DATE/TIME of APPT",20) D ;added "RTN","SDWLREB",94,0) .S ^TMP("SDWLREB",$J,.06)=SDFORM "RTN","SDWLREB",95,0) S ^TMP("SDWLREB",$J,.07)="-----------------------------------------------------------------------" "RTN","SDWLREB",96,0) S ^TMP("SDWLREB",$J,.08)="" "RTN","SDWLREB",97,0) N XMSUB,XMY,XMTEXT,XMDUZ "RTN","SDWLREB",98,0) S XMSUB="EWL opened entries with appointments 'CANCELED BY CLINIC'." "RTN","SDWLREB",99,0) S XMY("G.SD EWL BACKGROUND UPDATE")="" "RTN","SDWLREB",100,0) S XMTEXT="^TMP(""SDWLREB"",$J," "RTN","SDWLREB",101,0) S XMDUZ="POSTMASTER" "RTN","SDWLREB",102,0) D ^XMD K ^TMP("SDWLREB",$J) "RTN","SDWLREB",103,0) Q "RTN","SDWLREB",104,0) ASKDISP(IEN) ; "RTN","SDWLREB",105,0) ;IEN - pointer to 409.3 to get data and display "RTN","SDWLREB",106,0) N SDDIS S SDDIS=0 ; flag indicating disposition "RTN","SDWLREB",107,0) W ! N X,DIR,DENTER "RTN","SDWLREB",108,0) Q:$$GET1^DIQ(409.3,IEN_",",23,"I")="C" "RTN","SDWLREB",109,0) S ^TMP("SDWLPL",$J,IEN)=$G(^SDWL(409.3,IEN,0)) S DENTER="",DENTER=$P($G(^TMP("SDWLPL",$J,IEN)),"^",2) "RTN","SDWLREB",110,0) S (WLTYPE,TYPE,WLTN,NUM)="",TYPE=$P($G(^TMP("SDWLPL",$J,IEN)),"^",5) "RTN","SDWLREB",111,0) IF DENTER'=""&(TYPE'="") D "RTN","SDWLREB",112,0) .IF TYPE=1 S WLTYPE="PCMM TEAM",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",6),WLTNI=$$GET1^DIQ(404.51,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.51,NUM_",",.01) "RTN","SDWLREB",113,0) .IF TYPE=2 S WLTYPE="PCMM POSITION",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",7),WLTNI=$$GET1^DIQ(404.57,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.57,NUM_",",.01) "RTN","SDWLREB",114,0) .IF TYPE=3 S WLTYPE="SERV/SPECIALTY",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01) "RTN","SDWLREB",115,0) .IF TYPE=4 S WLTYPE="CLINIC",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01) "RTN","SDWLREB",116,0) E Q "RTN","SDWLREB",117,0) D SAVE(TYPE,WLTNI,IEN) "RTN","SDWLREB",118,0) Q "RTN","SDWLREB",119,0) SAVE(TYPE,WLTNI,IEN) ; "RTN","SDWLREB",120,0) ;TYPE - EWL type "RTN","SDWLREB",121,0) ;WLTNI - TYPE related name the EWL entry is waiting for "RTN","SDWLREB",122,0) ;IEN - pointer to 409.3 "RTN","SDWLREB",123,0) S REQBY=$P($G(^TMP("SDWLPL",$J,IEN)),"^",12) "RTN","SDWLREB",124,0) S INST=$P($G(^TMP("SDWLPL",$J,IEN)),"^",3) "RTN","SDWLREB",125,0) N DESIRED S DESIRED=$P($G(^TMP("SDWLPL",$J,IEN)),"^",16) "RTN","SDWLREB",126,0) N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09) "RTN","SDWLREB",127,0) N SDBY S SDBY=$$GET1^DIQ(409.3,IEN_",",11),SDBY=$E(SDBY,1,3) "RTN","SDWLREB",128,0) S NN=$O(^TMP($J,"SDWLPL",""),-1)+1 "RTN","SDWLREB",129,0) S ^TMP($J,"SDWLPL",NN)=IEN_U_WLTYPE_U_U_WLTN_U_INST_U_DENTER_U_SDBY_U_DESIRED "RTN","SDWLREB",130,0) ; "RTN","SDWLREB",131,0) N SPIEC S SPIEC=$S(TYPE=4:9,TYPE=3:10,TYPE=2:11,TYPE=1:12) "RTN","SDWLREB",132,0) S $P(^TMP($J,"SDWLPL",NN),U,SPIEC)=WLTNI "RTN","SDWLREB",133,0) K ^TMP("SDWLPL",$J,IEN) "RTN","SDWLREB",134,0) Q "RTN","SDWLREB",135,0) DISP ; "RTN","SDWLREB",136,0) W !,"EWL Entry has just been opened because of its matching appointment",!,"being canceled.",!! "RTN","SDWLREB",137,0) N DIR S DIR("B")="YES" ; default to match and close rebooked appointments "RTN","SDWLREB",138,0) S DIR("A")="Do you wish to close this EWL entry with Rebooked Appointment(Yes/No)",DIR(0)="Y" "RTN","SDWLREB",139,0) W "Closing this entry will disposition it: SA - REMOVED/SCHEDULED-ASSIGNED",!,"with Rebooked Appointment.",!! "RTN","SDWLREB",140,0) S DIR("?")="Y(ES) will disposition this EWL entry as 'SA' with just rebooked appointment." "RTN","SDWLREB",141,0) D LIST ; disable displaying EWL entry per SRS. "RTN","SDWLREB",142,0) W ! D ^DIR "RTN","SDWLREB",143,0) N SDDIS S SDDIS=0 I Y S SDDIS=1 "RTN","SDWLREB",144,0) E Q "RTN","SDWLREB",145,0) N SDWLDISP,SDWLDA,SDWLDFN,NUM "RTN","SDWLREB",146,0) I SDDIS S SDWLDISP="SA",NUM="" F S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM="" S REC=^TMP($J,"SDWLPL",NUM) D "RTN","SDWLREB",147,0) .S SDWLDA=+REC N SDP,SDR D "RTN","SDWLREB",148,0) .S DIE="^SDWL(409.3,",DA=SDWLDA,DR="21////^S X=SDWLDISP" D ^DIE "RTN","SDWLREB",149,0) .S DR="19////^S X=DT" D ^DIE "RTN","SDWLREB",150,0) .S DR="20////^S X=DUZ" D ^DIE "RTN","SDWLREB",151,0) .S DR="23////^S X=""C""" D ^DIE "RTN","SDWLREB",152,0) .;I SDWLDISP="SA" update with appointment data "RTN","SDWLREB",153,0) .;get appointment data to file (for a particular appt #) "RTN","SDWLREB",154,0) .I SDWLDISP="SA" N SDA D DATP^SDWLEVAL(1,.SDA) D "RTN","SDWLREB",155,0) ..I $D(SDA) S DIE="^SDWL(409.3,",DA=SDWLDA D "RTN","SDWLREB",156,0) ...S DR="13////"_SDA(1)_";13.1////"_DT_";13.2////"_SDA(2)_";13.3////"_SDA(15)_";13.4////"_SDA(13)_";13.5////"_SDA(14)_";13.6////"_SDA(16)_";13.8////"_SDA(3)_";13.7////"_DUZ "RTN","SDWLREB",157,0) ...D ^DIE "RTN","SDWLREB",158,0) .N SDWLSCL,SDWLSS,SDC "RTN","SDWLREB",159,0) .S SDC=1 "RTN","SDWLREB",160,0) .S SDWLSCL=$P($G(^TMP($J,"SDWLPL",SDC)),U,9) "RTN","SDWLREB",161,0) .S SDWLSS=$P($G(^TMP($J,"SDWLPL",SDC)),U,10) "RTN","SDWLREB",162,0) .I SDWLSCL K:$D(^SDWL(409.3,"SC",SDWLSCL,SDWLDA)) ^SDWL(409.3,"SC",SDWLSCL,SDWLDA) "RTN","SDWLREB",163,0) .S SDWLDFN=$P($G(^TMP($J,"APPT",1)),U,4) "RTN","SDWLREB",164,0) .I SDWLSS,SDWLDFN K:$D(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)) ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA) "RTN","SDWLREB",165,0) Q "RTN","SDWLREB",166,0) LIST ;LIST "RTN","SDWLREB",167,0) ;may be called if EWL entry display would be needed "RTN","SDWLREB",168,0) S (REC,NUM)="" N SDPN "RTN","SDWLREB",169,0) F S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM="" S REC=^TMP($J,"SDWLPL",NUM) D "RTN","SDWLREB",170,0) .S IEN=+REC N SDP,SDR D "RTN","SDWLREB",171,0) ..S SDPN=$$GET1^DIQ(409.3,IEN_",",.01) W !,"Patient: ",SDPN "RTN","SDWLREB",172,0) ..W !," EW List Type P Waiting for Institution Orig Date By Des. Date Reopen" "RTN","SDWLREB",173,0) ..W !,"--------------------------------------------------------------------------" "RTN","SDWLREB",174,0) ..S SDP=$E($$GET1^DIQ(409.3,IEN_",",10)) ;priority "RTN","SDWLREB",175,0) ..S SDR=$$GET1^DIQ(409.3,IEN_",",29,"I") ;reopen reason "RTN","SDWLREB",176,0) .N SDINS,SDIN S SDINS=$P(REC,"^",5) S SDIN=$$GET1^DIQ(4,SDINS_",",.01,"I") "RTN","SDWLREB",177,0) .W !,NUM_". ",$E($P(REC,"^",2),1,12),?17,SDP,?21,$E($P(REC,U,4),1,13),?35,SDIN,?45,$$FMTE^XLFDT($P(REC,"^",6),8),?57,$P(REC,"^",7),?61,$$FMTE^XLFDT($P(REC,"^",8),8),?76,SDR "RTN","SDWLREB",178,0) .N SDUP,SDLO "RTN","SDWLREB",179,0) .S SDUP="ABCDEFGHIJKLMNOPRSTUWQXYzv",SDLO="abcdefghijklmnoprstuwqxyzv" "RTN","SDWLREB",180,0) .N SMT S SMT=$$GET1^DIQ(409.3,IEN_",",25) I SMT'="" S SMT=$TR(SMT,SDUP,SDLO) W !?2,"Comment: ",SMT "RTN","SDWLREB",181,0) .N SMO S SMO=$$GET1^DIQ(409.3,IEN_",",30) I SMO'="" S SMO=$TR(SMO,SDUP,SDLO) W !?2,"Reopen: ",SMO "RTN","SDWLREB",182,0) K ANS1,NN,INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI "RTN","SDWLREB",183,0) K CLINIC,WLTYPE,TYPE,WLTN,NUM,REC "RTN","SDWLREB",184,0) Q "VER") 8.0^22.0 "^DD",409.32,409.32,.01,0) CLINIC^RP44I^SC(^0;1^Q "^DD",409.32,409.32,.01,1,0) ^.1^^-1 "^DD",409.32,409.32,.01,1,1,0) 409.32^B "^DD",409.32,409.32,.01,1,1,1) S ^SDWL(409.32,"B",$E(X,1,30),DA)="" "^DD",409.32,409.32,.01,1,1,2) K ^SDWL(409.32,"B",$E(X,1,30),DA) "^DD",409.32,409.32,.01,3) Select a clinic that can have patients on a Wait List "^DD",409.32,409.32,.01,21,0) ^.001^3^3^3060928^^^^ "^DD",409.32,409.32,.01,21,1,0) Enter clinics that are approved to be used by the "^DD",409.32,409.32,.01,21,2,0) Wait List(Sch/PCMM) application. "^DD",409.32,409.32,.01,21,3,0) Only active clinics in the Hospital Location file can be added. "^DD",409.32,409.32,.01,"DT") 3060928 "^DD",409.32,409.32,.02,0) INSTITUTION^R*P4'^DIC(4,^0;6^S DIC("S")="I $P(^(0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",409.32,409.32,.02,1,0) ^.1 "^DD",409.32,409.32,.02,1,1,0) 409.32^C "^DD",409.32,409.32,.02,1,1,1) S ^SDWL(409.32,"C",$E(X,1,30),DA)="" "^DD",409.32,409.32,.02,1,1,2) K ^SDWL(409.32,"C",$E(X,1,30),DA) "^DD",409.32,409.32,.02,1,1,"DT") 3020702 "^DD",409.32,409.32,.02,12) INSTITUTION must be NATIONAL and a treating facility. "^DD",409.32,409.32,.02,12.1) S DIC("S")="I $P(^(0),U,11)=""N"",$$TF^XUAF4(+Y)" "^DD",409.32,409.32,.02,21,0) ^.001^1^1^3070820^^^^ "^DD",409.32,409.32,.02,21,1,0) Institution of the clinic in the .01 field "^DD",409.32,409.32,.02,"DT") 3070709 "^DD",409.32,409.32,3,0) DATE INACTIVATED^D^^0;4^S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) K:$P(^SDWL(409.32,DA,0),U,2)>X X "^DD",409.32,409.32,3,1,0) ^.1 "^DD",409.32,409.32,3,1,1,0) 409.32^INA^MUMPS "^DD",409.32,409.32,3,1,1,1) I $D(X) K ^SDWL(409.32,"ACT",$P(^SDWL(409.32,DA,0),U,6),$P(^(0),U,1)) "^DD",409.32,409.32,3,1,1,2) Q "^DD",409.32,409.32,3,1,1,"DT") 3020819 "^DD",409.32,409.32,3,3) "^DD",409.32,409.32,3,21,0) ^.001^2^2^3080423^^^^ "^DD",409.32,409.32,3,21,1,0) Date clinic can no longer be used by the Wait List(Sch/PCMM). "^DD",409.32,409.32,3,21,2,0) It cannot be earlier than the activation date. "^DD",409.32,409.32,3,"DT") 3080423 "BLD",6897,6) ^437 **END** **END**