Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDWLCU6

SDWLCU6.m

Go to the documentation of this file.
  1. 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
  1. N XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1,CC
  1. N IEN,PAT,SDWLDTP S (IEN,PAT)="",(CC,SDWLPG,SDWLTP)=0,U="^",END=""
  1. D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y
  1. D HD
  1. F S PAT=$O(^SDWL(409.3,"B",PAT)) Q:PAT="" D
  1. .S IEN="" F S IEN=$O(^SDWL(409.3,"B",PAT,IEN)) Q:IEN="" D
  1. ..I '$D(^SDWL(409.3,IEN,0)) K ^SDWL(409.3,"B",PAT,IEN) L -^SDWL(409.3,IEN) Q ;SD/539
  1. ..N SDWLX S SDWLX=$G(^SDWL(409.3,IEN,0)) N SDCS S SDCS=$P(SDWLX,U,17)
  1. ..I SDCS="C" Q ; do not evaluate closed entries
  1. ..I DT'>$P(SDWLX,U,2),SDCS="" Q ; do not evaluate partially entered on the run date
  1. ..;evaluate CURRENT STATUS and if NULL close it
  1. ..I DT>$P(SDWLX,U,2),SDCS="" D Q ; this entry will be closed; ignore it
  1. ...N SDWLDISP,DA,DIE,DR S SDWLDISP="ER" ; NOT TO BE OPENED
  1. ...S DIE="^SDWL(409.3,",DA=IEN,DR="21////^S X=SDWLDISP" D ^DIE
  1. ...S DR="19////^S X=DT" D ^DIE
  1. ...S DR="20////^S X=.5" D ^DIE
  1. ...S DR="18////^S X=""Incomplete entry""" D ^DIE
  1. ...S DR="23////^S X=""C""" D ^DIE
  1. ..S XFLG="",XFL=1,SDWLWD="",SDWLTP1=""
  1. ..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
  1. ..I XFLG D
  1. ...N NN,NAME
  1. ...D HD:$Y+5>IOSL Q:END
  1. ...S NN="",NAME="" S NN=$P($G(^SDWL(409.3,IEN,0)),"^",1),NAME=$$GET1^DIQ(2,NN_",",.01,"E")
  1. ...S SDWLAPTD=$P(SDWLX,U,16) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y
  1. ...W !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$P(SDWLX,U,17),?58
  1. ...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))
  1. ...W XFL W:SDWLTP1'="" "/++"
  1. ...W:SDWLWD'="" !,?5,SDWLWD
  1. ...S CC=CC+1
  1. Q:END
  1. IF CC>.5 W !!,"TOTAL null field error EWL entries: "_CC
  1. 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"
  1. D CLINIC
  1. W !!,"** End of Report **"
  1. Q
  1. CLINIC ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message
  1. N CLINIC,INST,CC S INST="",CLINIC=0,CC=0
  1. F S CLINIC=$O(^SDWL(409.32,CLINIC)) Q:'CLINIC D
  1. . N CL,INSTST S CL=+$G(^SDWL(409.32,CLINIC,0)) Q:CL'>0
  1. . S INSTST=$$CLIN^SDWLPE(CL)
  1. . I $P(INSTST,U,6)'="" W !,*7,$P(INSTST,U,6) D
  1. .. S CC=CC+1
  1. .. I CC=1 W !!!,"The following clinics need to have the institution updated in file 44:",!!
  1. .. W !,?20,$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",.01)
  1. Q
  1. FIX ;fix corrupted Wait List Type piece 5
  1. S XFL1=0,SDWLTP1=""
  1. F J=6:1:9 S XDATA=$P(SDWLX,U,J) S:XDATA'="" XFL1=J
  1. I 'XFL1 S SDWLTP=SDWLTP+1,SDWLTP1="++" Q
  1. I XFL'=1,XFL=XFL1 Q
  1. S $P(SDWLX,U,5)=XFL1-5,XFL=XFL1,^SDWL(409.3,IEN,0)=SDWLX
  1. S SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$P("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")"
  1. Q
  1. HD ;HDR
  1. I SDWLPG>0,$E(IOST,1,2)="C-" S END=$$EOP() Q:END
  1. S SDWLPG=SDWLPG+1 W:SDWLPG'=1 @IOF
  1. S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD,?72,"Page: ",SDWLPG
  1. W !,?10,"Wait List Key Field 'NULL' Report for OPEN EWL entries."
  1. W !!,"STATION: "_+$$SITE^VASITE(,)
  1. W !!,"IEN Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields"
  1. Q
  1. EOP() ;end of page check - return 1 to quit, 0 to continue
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1. I $E(IOST,1,2)'="C-" Q 0 ; not to terminal
  1. F Q:($Y>(IOSL-2)) W !
  1. S DIR(0)="E"
  1. D ^DIR
  1. Q 'Y