SDWLCU1.m

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