source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU1.m@ 1361

SDWLCU1 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
 ;;5.3;scheduling;**280,427**;AUG 13 1993
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