- 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 Dec 13, 2024@03:02:19 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