source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLFUL1.m@ 1789

SDWLFUL1 ;;IOFO BAY PINES/TEH - REPAIR/RE-CAL ENROLLE STATUS;06/12/2002 ; 20 Aug 20022:10 PM
 ;;5.3;scheduling;**525**;AUG 13 1993;Build 47
 ;
 ;
 ;
 ;       TEMPORARY FILE:
 ;                                              1ST PECE         3RD PIECE        4TH PIECE
 ;       ^SDWL(409.39,$J,EWL_IEN,PAT_IEN)=ENROLLE CAL TF ^ ENROLLE CAL API ^ ENROLLE CAL VSSC ^ CURRENT CAL
 ;       
 ;       
 ;      
 ;       
 ;       
 ;       
 ;
EN ;
 I $D(^XTMP("SDWLFULSTAT",$J,3)) W !,"You have already run this OPTION." Q
 I '$D(^XTMP("SDWLFULSTAT",$J,2)) W !,"You must run OPTION 2 before OPTION 3." Q
 I '$D(^XTMP("SDWLFULSTAT",$J,"1B")) W !,"You must run a BACK-UP prior to running this option."
 D SETUP S DAX=0 F  S DAX=$O(^SDWL(409.3,DAX)) Q:DAX<1  D
 .I $P(^SDWL(409.3,DAX,0),"^",2)>SDWLSDAT Q
 .I $P(^SDWL(409.3,DAX,0),U,2)="" Q
 .W !,DAX," of ",DAXT," records."
 .S SDWLDFN=+$G(^SDWL(409.3,DAX,0)) I 'SDWLDFN Q
 .S SDWLODT=$P(^SDWL(409.3,DAX,0),U,2),(SDWLODX,X)=SDWLODT D H^%DTC S SDWLODT=%H
 .S SDWLEOLD=$P($G(^SDWL(409.3,DAX,0)),U,20)
 .;NEW ENTRY
 .S SDWLSSN=$$GET1^DIQ(2,SDWLDFN_",",.09)
 .S X=SDWLDFN,DIC(0)="Z",DIC="^SDWL(409.39," D FILE^DICN S SDWLDA=+Y
 .K DA,DIC,DR,DI,DIE,DO,Y
 .S DA=SDWLDA,DR="9////^S X=DAX",DIE="^SDWL(409.39," D ^DIE
 .S DR="4////^S X=SDWLEOLD" D ^DIE
 .K DA,DIC,DR,DI,DIE,DO,X,Y
 .S DIE="^SDWL(409.39,",DR="8////^S X=SDWLODX",DA=SDWLDA D ^DIE
 .K DA,DIC,DR,DI,DO,X,Y
 .S SDWLDE=SDWLODT,SDWLE=1,(SDWLEE,SDWLRNED,SDWLDB)=0
 .D A0,SET
 .D A1,SET
 .D A2,SET
 .S DIE="^SDWL(409.39,"
 .S DA=SDWLDA,SDWLDB=4 S SDWLRNE=SDWLEOLD,DR=SDWLDB_"////^S X=SDWLRNE" D ^DIE
 K DIE,DR,X,Y,DA,DAX,DIK,SDWLD,SDWLDA,SDWLDAT,SDWLDB,SDWLDE,SDWLDET,SDWLDFN
 K SDWLDS,SDWLDTT,SDWLE,SDWLEE,SDWLEOLD,SDWLODT,SDWLODX,SDWLRNE,SDWLRNED,SDWLSDAT
 K SDWLSSN,SDWLTDT,SDWLX,SDWLY,DAXT,%H,SDWLF,SDWLSET,SDWLXX
 S ^XTMP("SDWLFULSTAT",$J,3)=""
 Q
SET S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U"),DIE="^SDWL(409.39,",DA=SDWLDA
SET1 S DR=SDWLDB_"////^S X=SDWLRNE" D ^DIE
SET2 S DR=SDWLDB+4_"////^S X=SDWLDAT" D ^DIE
 S SDWLX=$G(^SDWL(409.39,SDWLDA,0)),SDWLF=0,SDWLSET=""
 S SDWLXX=$P(SDWLX,"^",2,4) I SDWLXX["E" S SDWLSET="E" D SET3 S SDWLF=1 Q
 I 'SDWLF,SDWLXX["P" S SDWLSET="P" D SET3 S SDWLF=1 Q
 I 'SDWLF,SDWLXX["N" S SDWLSET="N" D SET3 S SDWLF=1 Q
 I 'SDWLF S SDWLXX="U" S SDWLSET="U" D SET3 Q
 Q
SET3 S DR="8.1////^S X=SDWLSET",DIE=409.39,DA=SDWLDA D ^DIE
 K DIE,DR,X,Y,DA
 Q
A0 ;GET TREATMENT DATE FROM TREATING FACILITY FILE
 I '$D(^DGCN(391.91,"B",SDWLDFN)) S SDWLDB=1,SDWLDAT="" S SDWLE="" Q
 S SDWLX="",SDWLDAT="",SDWLDB=1,SDWLE=1 F  S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX=""  D
 .S SDWLY=$G(^DGCN(391.91,SDWLX,0)) D
 ..;CHECK FOR VALID TF
 ..I $$TF^XUAF4(+$P(SDWLY,U,2)) D
 ...;GET LIST OF DATES FOR TF
 ...S SDWLD=$P(SDWLY,U,3) S X=SDWLD D H^%DTC I %H>SDWLODT S SDWLD=0 Q
 ...I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
 ;FIND LAST TREATMENT DATE
 I '$D(SDWLDTF) Q
 S SDWLDTF=$O(SDWLDTF(0)) I SDWLDTF S (SDWLDAT,X)=9999999-SDWLDTF D H^%DTC
 S SDWLEE=SDWLDE-%H,SDWLDB=1 I SDWLEE<730 S SDWLE=2
 I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=3
 K SDWLDTF
 Q
A1 ;GET DATE FROM PATIENT ENROLLMENT
 S SDWLDB=2,SDWLDAT="" G A1B:SDWLE=2
 S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G A1A:$P(SDWLRNE,U,4)="A" S SDWLRNED=$P(SDWLRNE,U,3) D
 .S X=SDWLRNE D H^%DTC
 .I %H>SDWLODT S SDWLRNED=0
 I SDWLRNED S (SDWLDAT,X)=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=SDWLODT,SDWLDET=SDWLDE-SDWLDS,SDWLDB=2 I SDWLDET<366 S SDWLE=1
 I $D(SDWLDET),SDWLDET>365 S SDWLE=3
 I 'SDWLRNE S SDWLE=4
A1A I $D(SDWLRNE),$P(SDWLRNE,U,4)="A" D
 .I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=4 Q
 .I 'SDWLEE S SDWLE=4 Q
A1B Q
A2 ;GET TREATMENT DATE FROM VSSC FILE
 S SDWLDTT=SDWLODX,SDWLDE=SDWLODT,SDWLDB=3,SDWLDAT="",SDWLE="" D
 .I '$D(^XTMP("SDWLFUL",$J,SDWLSSN,SDWLDTT)) Q
 .S SDWLTDT=+$G(^XTMP("SDWLFUL",$J,SDWLSSN,SDWLDTT)),X=SDWLTDT D H^%DTC I %H'>SDWLODT D
 ..S SDWLDAT=SDWLTDT,SDWLEE=SDWLDE-%H,SDWLDB=3 I SDWLEE<730 S SDWLE=2
 ..I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=3
 Q
KILL S DA=0 F  S DA=$O(^SDWL(409.39,DA)) Q:DA<1  S DIK="^SDWL(409.39," D ^DIK
 Q
SETUP S X=^DIC(409.39,0) K ^SDWL(409.39) S ^SDWL(409.39,0)=X
 S SDWLX=$O(^XPD(9.7,"B","SD*5.3*485",999999999),-1)
 S SDWLSDAT=+$P(^XPD(9.7,SDWLX,0),"^",3)
 S DAXT=$P($G(^SDWL(409.3,0)),U,4)