SDWLCU1 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
;;5.3;scheduling;**280,427,1015**;AUG 13 1993;Build 21
INIT ;
S (IEN,REC,NUM,COUNT,TOTAL,WLTC1,WLTC2,WLTC3,WLTC4,INST,CODE,NAME,ANS)=""
S (INST1,INST2,INST3,INST4,POS,POSNAM,TEAM,TEAMN,CLINIC,CLINICN,CLNAM,SER,SERN,SERNAM)=""
K ^TMP($J,"SDWLCU1"),^TMP($J,"EWL"),SDWLERR
D START
D DISPLAY
D ^SDWLCU5
D NULL
W !!," ***** EWL CLEANUP RUN HAS FINISHED *****"
W !!,"==>> Run option until list is clean.",!
D EXIT
Q
START ;
F S INST=$O(^SDWL(409.3,"C",INST)) Q:INST<1 D
.S CODE=$$GET1^DIQ(4,INST_",",11,"I") D
..S IEN="" F S IEN=$O(^SDWL(409.3,"C",INST,IEN)) Q:IEN<1 D
...S INCK="" S INCK=$$TF^XUAF4(INST)
...IF CODE'="N"!('INCK) D SAVE
Q
SAVE ;
S ^TMP($J,"EWL",$J,IEN)=^SDWL(409.3,IEN,0)
IF +$P($G(^SDWL(409.3,IEN,0)),"^",5)=1 S WLTC1=WLTC1+1 D
.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)=""
IF +$P($G(^SDWL(409.3,IEN,0)),"^",5)=2 S WLTC2=WLTC2+1 D
.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)=""
IF +$P($G(^SDWL(409.3,IEN,0)),"^",5)=3 S WLTC3=WLTC3+1 D
.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)=""
IF +$P($G(^SDWL(409.3,IEN,0)),"^",5)=4 S WLTC4=WLTC4+1 D
.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)=""
Q
DISPLAY ;
S (CC,COUNT)="" F S CC=$O(^TMP($J,"EWL",$J,CC)) Q:CC="" S COUNT=COUNT+1
Q:COUNT<1
W #
W !,COUNT,?10,"ENTRIES IN SD WAIT LIST POINT TO AN INSTITUTION WITH"
W !,?10,"A STATUS NOT EQUAL TO NATIONAL OR ISN'T A TREATING FACILITY."
IF WLTC1>.5 S (COUNT1,INST)="" D
.F S INST=$O(^TMP($J,"SDWLCU1",1,INST)) Q:INST<1 D
..S IEN="" F S IEN=$O(^TMP($J,"SDWLCU1",1,INST,IEN)) Q:IEN="" S COUNT1=COUNT1+1
.W !!,WLTC1,?10,"ENTRIES POINT TO FILE TEAM (404.51) AND "
.W !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
IF WLTC2>.5 S (COUNT1,INST)="" D
.F S INST=$O(^TMP($J,"SDWLCU1",2,INST)) Q:INST<1 D
..S IEN="" F S IEN=$O(^TMP($J,"SDWLCU1",2,INST,IEN)) Q:IEN="" S COUNT1=COUNT1+1
.W !!,WLTC2,?10,"ENTRIES POINT TO FILE TEAM POSITION (404.57) AND "
.W !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
IF WLTC3>.5 S (COUNT1,INST)="" D
.F S INST=$O(^TMP($J,"SDWLCU1",3,INST)) Q:INST<1 D
..S IEN="" F S IEN=$O(^TMP($J,"SDWLCU1",3,INST,IEN)) Q:IEN="" S COUNT1=COUNT1+1
.W !!,WLTC3,?10,"ENTRIES POINT TO FILE SD WL SERVICE/SPECIALTY (409.31) AND"
.W !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
IF WLTC4>.5 S (COUNT1,INST)="" D
.F S INST=$O(^TMP($J,"SDWLCU1",4,INST)) Q:INST<1 D
..S IEN="" F S IEN=$O(^TMP($J,"SDWLCU1",4,INST,IEN)) Q:IEN="" S COUNT1=COUNT1+1
.W !!,WLTC4,?10,"ENTRIES POINT TO FILE SD WL CLINIC LOCATION (409.32) AND"
.W !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
EDIT ;
I WLTC1="",WLTC2="",WLTC3="",WLTC4="" Q
S X=""
I WLTC1 S X="1:PCMM TEAM ASSIGNMENT;"
I WLTC2 S X=X_"2:PCMM POSITION ASSIGNMENT;"
I WLTC3 S X=X_"3:SERVICE/SPECIALTY;"
I WLTC4 S X=X_"4:SPECIFIC CLINIC"
S DIR(0)="SO^"_X
S DIR("L",1)=" Select Wait List Type: (or Enter '^' to EXIT)"
S DIR("L",2)=""
S:WLTC1 DIR("L",3)=" 1. PCMM TEAM ASSIGNMENT"
S:WLTC2 DIR("L",4)=" 2. PCMM POSITION ASSIGNMENT"
S:WLTC3 DIR("L",5)=" 3. SERVICE/SPECIALTY"
S:WLTC4 DIR("L",6)=" 4. SPECIFIC CLINIC"
S DIR("A")="Select Wait List Type: (or Enter '^' to EXIT)"
D ^DIR G EXIT:$D(DUOUT),EDIT:Y=""
I Y=4!(Y=3) S SDWLTY=+Y,SDWLR=SDWLTY_"^SDWLCU3" D @SDWLR G DISPLAY
I Y=1!(Y=2) S SDWLTY=+Y,SDWLR=SDWLTY_"^SDWLCU2" D @SDWLR G DISPLAY
NULL ;
W !!,"** CHECK KEY FIELDS FOR NULL VALUE **",!!
QUE ;Queue Report
N ZTQUEUED,POP
K %ZIS,IOP,IOC,ZTIO,SDWLSPT S %ZIS="MQ" D ^%ZIS G:POP QUE1
S ZTRTN="^SDWLCU6",ZTDTH=$H,ZTDESC="WAIT LIST KEY FIELD-NULL REPORT"
;S SDWLTASK="" F S SDWLTASK=$O(^TMP("SDWLQOF",$J,SDWLTASK)) Q:SDWLTASK="" D
;.S SDWLTK=$G(^TMP("SDWLQOF",$J,SDWLTASK))
;.S ZTSAVE(SDWLTASK)=SDWLTK
I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"REQUEST QUEUED" G QEND
QUE1 I $D(ZTRTN) U IO D @ZTRTN
;
QEND ;
K DIR,DIC,DR,DIE,ZTDTH,ZTDESC,ZTRTN
D ^%ZISC
Q
EXIT ;
K ^TMP($J,"SDWLCU1"),^TMP($J,"EWL")
K IEN,REC,NUM,NN,COUNT,CC,TOTAL,WLTC1,WLTC2,WLTC3,WLTC4,INST,CODE,NAME,ANS,HEAD,INCK
K INST1,INST2,INST3,INST4,POS,POSNAM,TEAM,TEAMN,CLINIC,CLINICN,CLNAM,SER,SERN,SERNAM
K TEAM,TEAMN,INST,SSN,SDWLERR
K C,COUNT1,CS,ENTRY,PAT,SDREC,SDWLDA,SDWLI,SDWLIENS,SDWLIN,SDWLINS
K SDWLINSN,SDWLINST,SDWLIX,SDWLIZ,SDWLPO,SDWLR,SDWLSC,SDWLSCX,SDWLSS
K SDWLSSN,SDWLSSX,SDWLTM,SDWLTY,TAG,SDWLSSV,ZCC
Q
SDWLCU1 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
+1 ;;5.3;scheduling;**280,427,1015**;AUG 13 1993;Build 21
INIT ;
+1 SET (IEN,REC,NUM,COUNT,TOTAL,WLTC1,WLTC2,WLTC3,WLTC4,INST,CODE,NAME,ANS)=""
+2 SET (INST1,INST2,INST3,INST4,POS,POSNAM,TEAM,TEAMN,CLINIC,CLINICN,CLNAM,SER,SERN,SERNAM)=""
+3 KILL ^TMP($JOB,"SDWLCU1"),^TMP($JOB,"EWL"),SDWLERR
+4 DO START
+5 DO DISPLAY
+6 DO ^SDWLCU5
+7 DO NULL
+8 WRITE !!," ***** EWL CLEANUP RUN HAS FINISHED *****"
+9 WRITE !!,"==>> Run option until list is clean.",!
+10 DO EXIT
+11 QUIT
START ;
+1 FOR
SET INST=$ORDER(^SDWL(409.3,"C",INST))
IF INST<1
QUIT
Begin DoDot:1
+2 SET CODE=$$GET1^DIQ(4,INST_",",11,"I")
Begin DoDot:2
+3 SET IEN=""
FOR
SET IEN=$ORDER(^SDWL(409.3,"C",INST,IEN))
IF IEN<1
QUIT
Begin DoDot:3
+4 SET INCK=""
SET INCK=$$TF^XUAF4(INST)
+5 IF CODE'="N"!('INCK)
DO SAVE
End DoDot:3
End DoDot:2
End DoDot:1
+6 QUIT
SAVE ;
+1 SET ^TMP($JOB,"EWL",$JOB,IEN)=^SDWL(409.3,IEN,0)
+2 IF +$PIECE($GET(^SDWL(409.3,IEN,0)),"^",5)=1
SET WLTC1=WLTC1+1
Begin DoDot:1
+3 SET TEAM=+$PIECE($GET(^SDWL(409.3,IEN,0)),"^",6)
SET TEAMN=$PIECE(^SCTM(404.51,TEAM,0),"^",1)
SET ^TMP($JOB,"SDWLCU1",1,INST,TEAM,TEAMN,IEN)=""
End DoDot:1
+4 IF +$PIECE($GET(^SDWL(409.3,IEN,0)),"^",5)=2
SET WLTC2=WLTC2+1
Begin DoDot:1
+5 SET POS=+$PIECE($GET(^SDWL(409.3,IEN,0)),"^",7)
SET POSNAM=$PIECE(^SCTM(404.57,POS,0),"^",1)
SET ^TMP($JOB,"SDWLCU1",2,INST,POS,POSNAM,IEN)=""
End DoDot:1
+6 IF +$PIECE($GET(^SDWL(409.3,IEN,0)),"^",5)=3
SET WLTC3=WLTC3+1
Begin DoDot:1
+7 SET SER=+$PIECE($GET(^SDWL(409.3,IEN,0)),"^",8)
SET SERN=+$PIECE(^SDWL(409.31,SER,0),"^",1)
SET SERNAM=$$GET1^DIQ(40.7,SERN_",",.01)
SET ^TMP($JOB,"SDWLCU1",3,INST,SER,IEN)=""
End DoDot:1
+8 IF +$PIECE($GET(^SDWL(409.3,IEN,0)),"^",5)=4
SET WLTC4=WLTC4+1
Begin DoDot:1
+9 SET CLINIC=+$PIECE($GET(^SDWL(409.3,IEN,0)),"^",9)
SET CLINICN=+$PIECE(^SDWL(409.32,CLINIC,0),"^",1)
SET CLNAM=$$GET1^DIQ(44,CLINICN_",",.01)
SET ^TMP($JOB,"SDWLCU1",4,INST,CLINIC,IEN)=""
End DoDot:1
+10 QUIT
DISPLAY ;
+1 SET (CC,COUNT)=""
FOR
SET CC=$ORDER(^TMP($JOB,"EWL",$JOB,CC))
IF CC=""
QUIT
SET COUNT=COUNT+1
+2 IF COUNT<1
QUIT
+3 WRITE #
+4 WRITE !,COUNT,?10,"ENTRIES IN SD WAIT LIST POINT TO AN INSTITUTION WITH"
+5 WRITE !,?10,"A STATUS NOT EQUAL TO NATIONAL OR ISN'T A TREATING FACILITY."
+6 IF WLTC1>.5
SET (COUNT1,INST)=""
Begin DoDot:1
+7 FOR
SET INST=$ORDER(^TMP($JOB,"SDWLCU1",1,INST))
IF INST<1
QUIT
Begin DoDot:2
+8 SET IEN=""
FOR
SET IEN=$ORDER(^TMP($JOB,"SDWLCU1",1,INST,IEN))
IF IEN=""
QUIT
SET COUNT1=COUNT1+1
End DoDot:2
+9 WRITE !!,WLTC1,?10,"ENTRIES POINT TO FILE TEAM (404.51) AND "
+10 WRITE !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
End DoDot:1
+11 IF WLTC2>.5
SET (COUNT1,INST)=""
Begin DoDot:1
+12 FOR
SET INST=$ORDER(^TMP($JOB,"SDWLCU1",2,INST))
IF INST<1
QUIT
Begin DoDot:2
+13 SET IEN=""
FOR
SET IEN=$ORDER(^TMP($JOB,"SDWLCU1",2,INST,IEN))
IF IEN=""
QUIT
SET COUNT1=COUNT1+1
End DoDot:2
+14 WRITE !!,WLTC2,?10,"ENTRIES POINT TO FILE TEAM POSITION (404.57) AND "
+15 WRITE !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
End DoDot:1
+16 IF WLTC3>.5
SET (COUNT1,INST)=""
Begin DoDot:1
+17 FOR
SET INST=$ORDER(^TMP($JOB,"SDWLCU1",3,INST))
IF INST<1
QUIT
Begin DoDot:2
+18 SET IEN=""
FOR
SET IEN=$ORDER(^TMP($JOB,"SDWLCU1",3,INST,IEN))
IF IEN=""
QUIT
SET COUNT1=COUNT1+1
End DoDot:2
+19 WRITE !!,WLTC3,?10,"ENTRIES POINT TO FILE SD WL SERVICE/SPECIALTY (409.31) AND"
+20 WRITE !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
End DoDot:1
+21 IF WLTC4>.5
SET (COUNT1,INST)=""
Begin DoDot:1
+22 FOR
SET INST=$ORDER(^TMP($JOB,"SDWLCU1",4,INST))
IF INST<1
QUIT
Begin DoDot:2
+23 SET IEN=""
FOR
SET IEN=$ORDER(^TMP($JOB,"SDWLCU1",4,INST,IEN))
IF IEN=""
QUIT
SET COUNT1=COUNT1+1
End DoDot:2
+24 WRITE !!,WLTC4,?10,"ENTRIES POINT TO FILE SD WL CLINIC LOCATION (409.32) AND"
+25 WRITE !,COUNT1,?10,"INSTITUTION(S) MUST BE CORRECTED."
End DoDot:1
EDIT ;
+1 IF WLTC1=""
IF WLTC2=""
IF WLTC3=""
IF WLTC4=""
QUIT
+2 SET X=""
+3 IF WLTC1
SET X="1:PCMM TEAM ASSIGNMENT;"
+4 IF WLTC2
SET X=X_"2:PCMM POSITION ASSIGNMENT;"
+5 IF WLTC3
SET X=X_"3:SERVICE/SPECIALTY;"
+6 IF WLTC4
SET X=X_"4:SPECIFIC CLINIC"
+7 SET DIR(0)="SO^"_X
+8 SET DIR("L",1)=" Select Wait List Type: (or Enter '^' to EXIT)"
+9 SET DIR("L",2)=""
+10 IF WLTC1
SET DIR("L",3)=" 1. PCMM TEAM ASSIGNMENT"
+11 IF WLTC2
SET DIR("L",4)=" 2. PCMM POSITION ASSIGNMENT"
+12 IF WLTC3
SET DIR("L",5)=" 3. SERVICE/SPECIALTY"
+13 IF WLTC4
SET DIR("L",6)=" 4. SPECIFIC CLINIC"
+14 SET DIR("A")="Select Wait List Type: (or Enter '^' to EXIT)"
+15 DO ^DIR
IF $DATA(DUOUT)
GOTO EXIT
IF Y=""
GOTO EDIT
+16 IF Y=4!(Y=3)
SET SDWLTY=+Y
SET SDWLR=SDWLTY_"^SDWLCU3"
DO @SDWLR
GOTO DISPLAY
+17 IF Y=1!(Y=2)
SET SDWLTY=+Y
SET SDWLR=SDWLTY_"^SDWLCU2"
DO @SDWLR
GOTO DISPLAY
NULL ;
+1 WRITE !!,"** CHECK KEY FIELDS FOR NULL VALUE **",!!
QUE ;Queue Report
+1 NEW ZTQUEUED,POP
+2 KILL %ZIS,IOP,IOC,ZTIO,SDWLSPT
SET %ZIS="MQ"
DO ^%ZIS
IF POP
GOTO QUE1
+3 SET ZTRTN="^SDWLCU6"
SET ZTDTH=$HOROLOG
SET ZTDESC="WAIT LIST KEY FIELD-NULL REPORT"
+4 ;S SDWLTASK="" F S SDWLTASK=$O(^TMP("SDWLQOF",$J,SDWLTASK)) Q:SDWLTASK="" D
+5 ;.S SDWLTK=$G(^TMP("SDWLQOF",$J,SDWLTASK))
+6 ;.S ZTSAVE(SDWLTASK)=SDWLTK
+7 IF $DATA(IO("Q"))
KILL IO("Q")
DO ^%ZTLOAD
WRITE !,"REQUEST QUEUED"
GOTO QEND
QUE1 IF $DATA(ZTRTN)
USE IO
DO @ZTRTN
+1 ;
QEND ;
+1 KILL DIR,DIC,DR,DIE,ZTDTH,ZTDESC,ZTRTN
+2 DO ^%ZISC
+3 QUIT
EXIT ;
+1 KILL ^TMP($JOB,"SDWLCU1"),^TMP($JOB,"EWL")
+2 KILL IEN,REC,NUM,NN,COUNT,CC,TOTAL,WLTC1,WLTC2,WLTC3,WLTC4,INST,CODE,NAME,ANS,HEAD,INCK
+3 KILL INST1,INST2,INST3,INST4,POS,POSNAM,TEAM,TEAMN,CLINIC,CLINICN,CLNAM,SER,SERN,SERNAM
+4 KILL TEAM,TEAMN,INST,SSN,SDWLERR
+5 KILL C,COUNT1,CS,ENTRY,PAT,SDREC,SDWLDA,SDWLI,SDWLIENS,SDWLIN,SDWLINS
+6 KILL SDWLINSN,SDWLINST,SDWLIX,SDWLIZ,SDWLPO,SDWLR,SDWLSC,SDWLSCX,SDWLSS
+7 KILL SDWLSSN,SDWLSSX,SDWLTM,SDWLTY,TAG,SDWLSSV,ZCC
+8 QUIT
