source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLCU1.m@ 1765

Last change on this file since 1765 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1SDWLCU1 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
2 ;;5.3;scheduling;**280,427**;AUG 13 1993
3INIT ;
4 S (IEN,REC,NUM,COUNT,TOTAL,WLTC1,WLTC2,WLTC3,WLTC4,INST,CODE,NAME,ANS)=""
5 S (INST1,INST2,INST3,INST4,POS,POSNAM,TEAM,TEAMN,CLINIC,CLINICN,CLNAM,SER,SERN,SERNAM)=""
6 K ^TMP($J,"SDWLCU1"),^TMP($J,"EWL"),SDWLERR
7 D START
8 D DISPLAY
9 D ^SDWLCU5
10 D NULL
11 W !!," ***** EWL CLEANUP RUN HAS FINISHED *****"
12 W !!,"==>> Run option until list is clean.",!
13 D EXIT
14 Q
15START ;
16 F S INST=$O(^SDWL(409.3,"C",INST)) Q:INST<1 D
17 .S CODE=$$GET1^DIQ(4,INST_",",11,"I") D
18 ..S IEN="" F S IEN=$O(^SDWL(409.3,"C",INST,IEN)) Q:IEN<1 D
19 ...S INCK="" S INCK=$$TF^XUAF4(INST)
20 ...IF CODE'="N"!('INCK) D SAVE
21 Q
22SAVE ;
23 S ^TMP($J,"EWL",$J,IEN)=^SDWL(409.3,IEN,0)
24 IF +$P($G(^SDWL(409.3,IEN,0)),"^",5)=1 S WLTC1=WLTC1+1 D
25 .S TEAM=+$P($G(^SDWL(409.3,IEN,0)),"^",6),TEAMN=$P(^SCTM(404.51,TEAM,0),"^",1),^TMP($J,"SDWLCU1",1,INST,TEAM,TEAMN,IEN)=""
26 IF +$P($G(^SDWL(409.3,IEN,0)),"^",5)=2 S WLTC2=WLTC2+1 D
27 .S POS=+$P($G(^SDWL(409.3,IEN,0)),"^",7),POSNAM=$P(^SCTM(404.57,POS,0),"^",1),^TMP($J,"SDWLCU1",2,INST,POS,POSNAM,IEN)=""
28 IF +$P($G(^SDWL(409.3,IEN,0)),"^",5)=3 S WLTC3=WLTC3+1 D
29 .S SER=+$P($G(^SDWL(409.3,IEN,0)),"^",8),SERN=+$P(^SDWL(409.31,SER,0),"^",1),SERNAM=$$GET1^DIQ(40.7,SERN_",",.01),^TMP($J,"SDWLCU1",3,INST,SER,IEN)=""
30 IF +$P($G(^SDWL(409.3,IEN,0)),"^",5)=4 S WLTC4=WLTC4+1 D
31 .S CLINIC=+$P($G(^SDWL(409.3,IEN,0)),"^",9),CLINICN=+$P(^SDWL(409.32,CLINIC,0),"^",1),CLNAM=$$GET1^DIQ(44,CLINICN_",",.01),^TMP($J,"SDWLCU1",4,INST,CLINIC,IEN)=""
32 Q
33DISPLAY ;
34 S (CC,COUNT)="" F S CC=$O(^TMP($J,"EWL",$J,CC)) Q:CC="" S COUNT=COUNT+1
35 Q:COUNT<1
36 W #
37 W !,COUNT,?10,"ENTRIES IN SD WAIT LIST POINT TO AN INSTITUTION WITH"
38 W !,?10,"A STATUS NOT EQUAL TO NATIONAL OR ISN'T A TREATING FACILITY."
39 IF WLTC1>.5 S (COUNT1,INST)="" D
40 .F S INST=$O(^TMP($J,"SDWLCU1",1,INST)) Q:INST<1 D
41 ..S IEN="" F S IEN=$O(^TMP($J,"SDWLCU1",1,INST,IEN)) Q:IEN="" S COUNT1=COUNT1+1
42 .W !!,WLTC1,?10,"ENTRIES POINT TO FILE TEAM (404.51) AND "
43 .W !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
44 IF WLTC2>.5 S (COUNT1,INST)="" D
45 .F S INST=$O(^TMP($J,"SDWLCU1",2,INST)) Q:INST<1 D
46 ..S IEN="" F S IEN=$O(^TMP($J,"SDWLCU1",2,INST,IEN)) Q:IEN="" S COUNT1=COUNT1+1
47 .W !!,WLTC2,?10,"ENTRIES POINT TO FILE TEAM POSITION (404.57) AND "
48 .W !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
49 IF WLTC3>.5 S (COUNT1,INST)="" D
50 .F S INST=$O(^TMP($J,"SDWLCU1",3,INST)) Q:INST<1 D
51 ..S IEN="" F S IEN=$O(^TMP($J,"SDWLCU1",3,INST,IEN)) Q:IEN="" S COUNT1=COUNT1+1
52 .W !!,WLTC3,?10,"ENTRIES POINT TO FILE SD WL SERVICE/SPECIALTY (409.31) AND"
53 .W !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
54 IF WLTC4>.5 S (COUNT1,INST)="" D
55 .F S INST=$O(^TMP($J,"SDWLCU1",4,INST)) Q:INST<1 D
56 ..S IEN="" F S IEN=$O(^TMP($J,"SDWLCU1",4,INST,IEN)) Q:IEN="" S COUNT1=COUNT1+1
57 .W !!,WLTC4,?10,"ENTRIES POINT TO FILE SD WL CLINIC LOCATION (409.32) AND"
58 .W !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
59EDIT ;
60 I WLTC1="",WLTC2="",WLTC3="",WLTC4="" Q
61 S X=""
62 I WLTC1 S X="1:PCMM TEAM ASSIGNMENT;"
63 I WLTC2 S X=X_"2:PCMM POSITION ASSIGNMENT;"
64 I WLTC3 S X=X_"3:SERVICE/SPECIALTY;"
65 I WLTC4 S X=X_"4:SPECIFIC CLINIC"
66 S DIR(0)="SO^"_X
67 S DIR("L",1)=" Select Wait List Type: (or Enter '^' to EXIT)"
68 S DIR("L",2)=""
69 S:WLTC1 DIR("L",3)=" 1. PCMM TEAM ASSIGNMENT"
70 S:WLTC2 DIR("L",4)=" 2. PCMM POSITION ASSIGNMENT"
71 S:WLTC3 DIR("L",5)=" 3. SERVICE/SPECIALTY"
72 S:WLTC4 DIR("L",6)=" 4. SPECIFIC CLINIC"
73 S DIR("A")="Select Wait List Type: (or Enter '^' to EXIT)"
74 D ^DIR G EXIT:$D(DUOUT),EDIT:Y=""
75 I Y=4!(Y=3) S SDWLTY=+Y,SDWLR=SDWLTY_"^SDWLCU3" D @SDWLR G DISPLAY
76 I Y=1!(Y=2) S SDWLTY=+Y,SDWLR=SDWLTY_"^SDWLCU2" D @SDWLR G DISPLAY
77NULL ;
78 W !!,"** CHECK KEY FIELDS FOR NULL VALUE **",!!
79QUE ;Queue Report
80 N ZTQUEUED,POP
81 K %ZIS,IOP,IOC,ZTIO,SDWLSPT S %ZIS="MQ" D ^%ZIS G:POP QUE1
82 S ZTRTN="^SDWLCU6",ZTDTH=$H,ZTDESC="WAIT LIST KEY FIELD-NULL REPORT"
83 ;S SDWLTASK="" F S SDWLTASK=$O(^TMP("SDWLQOF",$J,SDWLTASK)) Q:SDWLTASK="" D
84 ;.S SDWLTK=$G(^TMP("SDWLQOF",$J,SDWLTASK))
85 ;.S ZTSAVE(SDWLTASK)=SDWLTK
86 I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"REQUEST QUEUED" G QEND
87QUE1 I $D(ZTRTN) U IO D @ZTRTN
88 ;
89QEND ;
90 K DIR,DIC,DR,DIE,ZTDTH,ZTDESC,ZTRTN
91 D ^%ZISC
92 Q
93EXIT ;
94 K ^TMP($J,"SDWLCU1"),^TMP($J,"EWL")
95 K IEN,REC,NUM,NN,COUNT,CC,TOTAL,WLTC1,WLTC2,WLTC3,WLTC4,INST,CODE,NAME,ANS,HEAD,INCK
96 K INST1,INST2,INST3,INST4,POS,POSNAM,TEAM,TEAMN,CLINIC,CLINICN,CLNAM,SER,SERN,SERNAM
97 K TEAM,TEAMN,INST,SSN,SDWLERR
98 K C,COUNT1,CS,ENTRY,PAT,SDREC,SDWLDA,SDWLI,SDWLIENS,SDWLIN,SDWLINS
99 K SDWLINSN,SDWLINST,SDWLIX,SDWLIZ,SDWLPO,SDWLR,SDWLSC,SDWLSCX,SDWLSS
100 K SDWLSSN,SDWLSSX,SDWLTM,SDWLTY,TAG,SDWLSSV,ZCC
101 Q
Note: See TracBrowser for help on using the repository browser.