SDWLCU6 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP - print ;2/15/05
;;5.3;scheduling;**427,491,539**;AUG 13 1993;Build 24
N XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1,CC
N IEN,PAT,SDWLDTP S (IEN,PAT)="",(CC,SDWLPG,SDWLTP)=0,U="^",END=""
D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y
D HD
F S PAT=$O(^SDWL(409.3,"B",PAT)) Q:PAT="" D
.S IEN="" F S IEN=$O(^SDWL(409.3,"B",PAT,IEN)) Q:IEN="" D
..I '$D(^SDWL(409.3,IEN,0)) K ^SDWL(409.3,"B",PAT,IEN) L -^SDWL(409.3,IEN) Q ;SD/539
..N SDWLX S SDWLX=$G(^SDWL(409.3,IEN,0)) N SDCS S SDCS=$P(SDWLX,U,17)
..I SDCS="C" Q ; do not evaluate closed entries
..I DT'>$P(SDWLX,U,2),SDCS="" Q ; do not evaluate partially entered on the run date
..;evaluate CURRENT STATUS and if NULL close it
..I DT>$P(SDWLX,U,2),SDCS="" D Q ; this entry will be closed; ignore it
...N SDWLDISP,DA,DIE,DR S SDWLDISP="ER" ; NOT TO BE OPENED
...S DIE="^SDWL(409.3,",DA=IEN,DR="21////^S X=SDWLDISP" D ^DIE
...S DR="19////^S X=DT" D ^DIE
...S DR="20////^S X=.5" D ^DIE
...S DR="18////^S X=""Incomplete entry""" D ^DIE
...S DR="23////^S X=""C""" D ^DIE
..S XFLG="",XFL=1,SDWLWD="",SDWLTP1=""
..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
..I XFLG D
...N NN,NAME
...D HD:$Y+5>IOSL Q:END
...S NN="",NAME="" S NN=$P($G(^SDWL(409.3,IEN,0)),"^",1),NAME=$$GET1^DIQ(2,NN_",",.01,"E")
...S SDWLAPTD=$P(SDWLX,U,16) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y
...W !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$P(SDWLX,U,17),?58
...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))
...W XFL W:SDWLTP1'="" "/++"
...W:SDWLWD'="" !,?5,SDWLWD
...S CC=CC+1
Q:END
IF CC>.5 W !!,"TOTAL null field error EWL entries: "_CC
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"
D CLINIC
W !!,"** End of Report **"
Q
CLINIC ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message
N CLINIC,INST,CC S INST="",CLINIC=0,CC=0
F S CLINIC=$O(^SDWL(409.32,CLINIC)) Q:'CLINIC D
. N CL,INSTST S CL=+$G(^SDWL(409.32,CLINIC,0)) Q:CL'>0
. S INSTST=$$CLIN^SDWLPE(CL)
. I $P(INSTST,U,6)'="" W !,*7,$P(INSTST,U,6) D
.. S CC=CC+1
.. I CC=1 W !!!,"The following clinics need to have the institution updated in file 44:",!!
.. W !,?20,$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",.01)
Q
FIX ;fix corrupted Wait List Type piece 5
S XFL1=0,SDWLTP1=""
F J=6:1:9 S XDATA=$P(SDWLX,U,J) S:XDATA'="" XFL1=J
I 'XFL1 S SDWLTP=SDWLTP+1,SDWLTP1="++" Q
I XFL'=1,XFL=XFL1 Q
S $P(SDWLX,U,5)=XFL1-5,XFL=XFL1,^SDWL(409.3,IEN,0)=SDWLX
S SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$P("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")"
Q
HD ;HDR
I SDWLPG>0,$E(IOST,1,2)="C-" S END=$$EOP() Q:END
S SDWLPG=SDWLPG+1 W:SDWLPG'=1 @IOF
S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD,?72,"Page: ",SDWLPG
W !,?10,"Wait List Key Field 'NULL' Report for OPEN EWL entries."
W !!,"STATION: "_+$$SITE^VASITE(,)
W !!,"IEN Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields"
Q
EOP() ;end of page check - return 1 to quit, 0 to continue
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
I $E(IOST,1,2)'="C-" Q 0 ; not to terminal
F Q:($Y>(IOSL-2)) W !
S DIR(0)="E"
D ^DIR
Q 'Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLCU6 3531 printed Nov 22, 2024@18:12:11 Page 2
SDWLCU6 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP - print ;2/15/05
+1 ;;5.3;scheduling;**427,491,539**;AUG 13 1993;Build 24
+2 NEW XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1,CC
+3 NEW IEN,PAT,SDWLDTP
SET (IEN,PAT)=""
SET (CC,SDWLPG,SDWLTP)=0
SET U="^"
SET END=""
+4 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET SDWLDTP=Y
+5 DO HD
+6 FOR
SET PAT=$ORDER(^SDWL(409.3,"B",PAT))
if PAT=""
QUIT
Begin DoDot:1
+7 SET IEN=""
FOR
SET IEN=$ORDER(^SDWL(409.3,"B",PAT,IEN))
if IEN=""
QUIT
Begin DoDot:2
+8 ;SD/539
IF '$DATA(^SDWL(409.3,IEN,0))
KILL ^SDWL(409.3,"B",PAT,IEN)
LOCK -^SDWL(409.3,IEN)
QUIT
+9 NEW SDWLX
SET SDWLX=$GET(^SDWL(409.3,IEN,0))
NEW SDCS
SET SDCS=$PIECE(SDWLX,U,17)
+10 ; do not evaluate closed entries
IF SDCS="C"
QUIT
+11 ; do not evaluate partially entered on the run date
IF DT'>$PIECE(SDWLX,U,2)
IF SDCS=""
QUIT
+12 ;evaluate CURRENT STATUS and if NULL close it
+13 ; this entry will be closed; ignore it
IF DT>$PIECE(SDWLX,U,2)
IF SDCS=""
Begin DoDot:3
+14 ; NOT TO BE OPENED
NEW SDWLDISP,DA,DIE,DR
SET SDWLDISP="ER"
+15 SET DIE="^SDWL(409.3,"
SET DA=IEN
SET DR="21////^S X=SDWLDISP"
DO ^DIE
+16 SET DR="19////^S X=DT"
DO ^DIE
+17 SET DR="20////^S X=.5"
DO ^DIE
+18 SET DR="18////^S X=""Incomplete entry"""
DO ^DIE
+19 SET DR="23////^S X=""C"""
DO ^DIE
End DoDot:3
QUIT
+20 SET XFLG=""
SET XFL=1
SET SDWLWD=""
SET SDWLTP1=""
+21 FOR I=3,5,XFL
SET XDATA=$PIECE(SDWLX,U,I)
if I=5&XDATA
SET XFL=XDATA+5
if 'XDATA
SET XFLG=XFLG_I
IF I=5
IF XFL=1
DO FIX
+22 IF XFLG
Begin DoDot:3
+23 NEW NN,NAME
+24 if $Y+5>IOSL
DO HD
if END
QUIT
+25 SET NN=""
SET NAME=""
SET NN=$PIECE($GET(^SDWL(409.3,IEN,0)),"^",1)
SET NAME=$$GET1^DIQ(2,NN_",",.01,"E")
+26 SET SDWLAPTD=$PIECE(SDWLX,U,16)
IF SDWLAPTD'=""
SET Y=SDWLAPTD
DO DD^%DT
SET SDWLAPTD=Y
+27 WRITE !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$PIECE(SDWLX,U,17),?58
+28 SET XFL=""
FOR I=1:1:3
if $EXTRACT(XFLG,I)=""
QUIT
SET XFL=XFL_$SELECT(XFL'="":",",1:"")_$PIECE("::INST::Type:Team:Postn:Srv/Spec:Clinic",":",$EXTRACT(XFLG,I))
+29 WRITE XFL
if SDWLTP1'=""
WRITE "/++"
+30 if SDWLWD'=""
WRITE !,?5,SDWLWD
+31 SET CC=CC+1
End DoDot:3
End DoDot:2
End DoDot:1
+32 if END
QUIT
+33 IF CC>.5
WRITE !!,"TOTAL null field error EWL entries: "_CC
+34 IF SDWLTP>.5
WRITE !!,"++ 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"
+35 DO CLINIC
+36 WRITE !!,"** End of Report **"
+37 QUIT
CLINIC ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message
+1 NEW CLINIC,INST,CC
SET INST=""
SET CLINIC=0
SET CC=0
+2 FOR
SET CLINIC=$ORDER(^SDWL(409.32,CLINIC))
if 'CLINIC
QUIT
Begin DoDot:1
+3 NEW CL,INSTST
SET CL=+$GET(^SDWL(409.32,CLINIC,0))
if CL'>0
QUIT
+4 SET INSTST=$$CLIN^SDWLPE(CL)
+5 IF $PIECE(INSTST,U,6)'=""
WRITE !,*7,$PIECE(INSTST,U,6)
Begin DoDot:2
+6 SET CC=CC+1
+7 IF CC=1
WRITE !!!,"The following clinics need to have the institution updated in file 44:",!!
+8 WRITE !,?20,$$GET1^DIQ(44,+$GET(^SDWL(409.32,CLINIC,0))_",",.01)
End DoDot:2
End DoDot:1
+9 QUIT
FIX ;fix corrupted Wait List Type piece 5
+1 SET XFL1=0
SET SDWLTP1=""
+2 FOR J=6:1:9
SET XDATA=$PIECE(SDWLX,U,J)
if XDATA'=""
SET XFL1=J
+3 IF 'XFL1
SET SDWLTP=SDWLTP+1
SET SDWLTP1="++"
QUIT
+4 IF XFL'=1
IF XFL=XFL1
QUIT
+5 SET $PIECE(SDWLX,U,5)=XFL1-5
SET XFL=XFL1
SET ^SDWL(409.3,IEN,0)=SDWLX
+6 SET SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$PIECE("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")"
+7 QUIT
HD ;HDR
+1 IF SDWLPG>0
IF $EXTRACT(IOST,1,2)="C-"
SET END=$$EOP()
if END
QUIT
+2 SET SDWLPG=SDWLPG+1
if SDWLPG'=1
WRITE @IOF
+3 SET Y=DT
DO DD^%DT
SET SDWLPD=Y
WRITE ?57,SDWLPD,?72,"Page: ",SDWLPG
+4 WRITE !,?10,"Wait List Key Field 'NULL' Report for OPEN EWL entries."
+5 WRITE !!,"STATION: "_+$$SITE^VASITE(,)
+6 WRITE !!,"IEN Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields"
+7 QUIT
EOP() ;end of page check - return 1 to quit, 0 to continue
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 ; not to terminal
IF $EXTRACT(IOST,1,2)'="C-"
QUIT 0
+3 FOR
if ($Y>(IOSL-2))
QUIT
WRITE !
+4 SET DIR(0)="E"
+5 DO ^DIR
+6 QUIT 'Y
