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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLFUL1 4349 printed Apr 09, 2024@21:56:43 Page 2
SDWLFUL1 ;;IOFO BAY PINES/TEH - REPAIR/RE-CAL ENROLLE STATUS;06/12/2002 ; 20 Aug 20022:10 PM
+1 ;;5.3;scheduling;**525**;AUG 13 1993;Build 47
+2 ;
+3 ;
+4 ;
+5 ; TEMPORARY FILE:
+6 ; 1ST PECE 3RD PIECE 4TH PIECE
+7 ; ^SDWL(409.39,$J,EWL_IEN,PAT_IEN)=ENROLLE CAL TF ^ ENROLLE CAL API ^ ENROLLE CAL VSSC ^ CURRENT CAL
+8 ;
+9 ;
+10 ;
+11 ;
+12 ;
+13 ;
+14 ;
EN ;
+1 IF $DATA(^XTMP("SDWLFULSTAT",$JOB,3))
WRITE !,"You have already run this OPTION."
QUIT
+2 IF '$DATA(^XTMP("SDWLFULSTAT",$JOB,2))
WRITE !,"You must run OPTION 2 before OPTION 3."
QUIT
+3 IF '$DATA(^XTMP("SDWLFULSTAT",$JOB,"1B"))
WRITE !,"You must run a BACK-UP prior to running this option."
+4 DO SETUP
SET DAX=0
FOR
SET DAX=$ORDER(^SDWL(409.3,DAX))
if DAX<1
QUIT
Begin DoDot:1
+5 IF $PIECE(^SDWL(409.3,DAX,0),"^",2)>SDWLSDAT
QUIT
+6 IF $PIECE(^SDWL(409.3,DAX,0),U,2)=""
QUIT
+7 WRITE !,DAX," of ",DAXT," records."
+8 SET SDWLDFN=+$GET(^SDWL(409.3,DAX,0))
IF 'SDWLDFN
QUIT
+9 SET SDWLODT=$PIECE(^SDWL(409.3,DAX,0),U,2)
SET (SDWLODX,X)=SDWLODT
DO H^%DTC
SET SDWLODT=%H
+10 SET SDWLEOLD=$PIECE($GET(^SDWL(409.3,DAX,0)),U,20)
+11 ;NEW ENTRY
+12 SET SDWLSSN=$$GET1^DIQ(2,SDWLDFN_",",.09)
+13 SET X=SDWLDFN
SET DIC(0)="Z"
SET DIC="^SDWL(409.39,"
DO FILE^DICN
SET SDWLDA=+Y
+14 KILL DA,DIC,DR,DI,DIE,DO,Y
+15 SET DA=SDWLDA
SET DR="9////^S X=DAX"
SET DIE="^SDWL(409.39,"
DO ^DIE
+16 SET DR="4////^S X=SDWLEOLD"
DO ^DIE
+17 KILL DA,DIC,DR,DI,DIE,DO,X,Y
+18 SET DIE="^SDWL(409.39,"
SET DR="8////^S X=SDWLODX"
SET DA=SDWLDA
DO ^DIE
+19 KILL DA,DIC,DR,DI,DO,X,Y
+20 SET SDWLDE=SDWLODT
SET SDWLE=1
SET (SDWLEE,SDWLRNED,SDWLDB)=0
+21 DO A0
DO SET
+22 DO A1
DO SET
+23 DO A2
DO SET
+24 SET DIE="^SDWL(409.39,"
+25 SET DA=SDWLDA
SET SDWLDB=4
SET SDWLRNE=SDWLEOLD
SET DR=SDWLDB_"////^S X=SDWLRNE"
DO ^DIE
End DoDot:1
+26 KILL DIE,DR,X,Y,DA,DAX,DIK,SDWLD,SDWLDA,SDWLDAT,SDWLDB,SDWLDE,SDWLDET,SDWLDFN
+27 KILL SDWLDS,SDWLDTT,SDWLE,SDWLEE,SDWLEOLD,SDWLODT,SDWLODX,SDWLRNE,SDWLRNED,SDWLSDAT
+28 KILL SDWLSSN,SDWLTDT,SDWLX,SDWLY,DAXT,%H,SDWLF,SDWLSET,SDWLXX
+29 SET ^XTMP("SDWLFULSTAT",$JOB,3)=""
+30 QUIT
SET SET SDWLRNE=$SELECT(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
SET DIE="^SDWL(409.39,"
SET DA=SDWLDA
SET1 SET DR=SDWLDB_"////^S X=SDWLRNE"
DO ^DIE
SET2 SET DR=SDWLDB+4_"////^S X=SDWLDAT"
DO ^DIE
+1 SET SDWLX=$GET(^SDWL(409.39,SDWLDA,0))
SET SDWLF=0
SET SDWLSET=""
+2 SET SDWLXX=$PIECE(SDWLX,"^",2,4)
IF SDWLXX["E"
SET SDWLSET="E"
DO SET3
SET SDWLF=1
QUIT
+3 IF 'SDWLF
IF SDWLXX["P"
SET SDWLSET="P"
DO SET3
SET SDWLF=1
QUIT
+4 IF 'SDWLF
IF SDWLXX["N"
SET SDWLSET="N"
DO SET3
SET SDWLF=1
QUIT
+5 IF 'SDWLF
SET SDWLXX="U"
SET SDWLSET="U"
DO SET3
QUIT
+6 QUIT
SET3 SET DR="8.1////^S X=SDWLSET"
SET DIE=409.39
SET DA=SDWLDA
DO ^DIE
+1 KILL DIE,DR,X,Y,DA
+2 QUIT
A0 ;GET TREATMENT DATE FROM TREATING FACILITY FILE
+1 IF '$DATA(^DGCN(391.91,"B",SDWLDFN))
SET SDWLDB=1
SET SDWLDAT=""
SET SDWLE=""
QUIT
+2 SET SDWLX=""
SET SDWLDAT=""
SET SDWLDB=1
SET SDWLE=1
FOR
SET SDWLX=$ORDER(^DGCN(391.91,"B",SDWLDFN,SDWLX))
if SDWLX=""
QUIT
Begin DoDot:1
+3 SET SDWLY=$GET(^DGCN(391.91,SDWLX,0))
Begin DoDot:2
+4 ;CHECK FOR VALID TF
+5 IF $$TF^XUAF4(+$PIECE(SDWLY,U,2))
Begin DoDot:3
+6 ;GET LIST OF DATES FOR TF
+7 SET SDWLD=$PIECE(SDWLY,U,3)
SET X=SDWLD
DO H^%DTC
IF %H>SDWLODT
SET SDWLD=0
QUIT
+8 IF SDWLD
SET SDWLDTF(9999999-SDWLD)=SDWLX
End DoDot:3
End DoDot:2
End DoDot:1
+9 ;FIND LAST TREATMENT DATE
+10 IF '$DATA(SDWLDTF)
QUIT
+11 SET SDWLDTF=$ORDER(SDWLDTF(0))
IF SDWLDTF
SET (SDWLDAT,X)=9999999-SDWLDTF
DO H^%DTC
+12 SET SDWLEE=SDWLDE-%H
SET SDWLDB=1
IF SDWLEE<730
SET SDWLE=2
+13 IF $DATA(SDWLEE)
IF SDWLEE>730!(SDWLEE=730)
SET SDWLE=3
+14 KILL SDWLDTF
+15 QUIT
A1 ;GET DATE FROM PATIENT ENROLLMENT
+1 SET SDWLDB=2
SET SDWLDAT=""
if SDWLE=2
GOTO A1B
+2 SET SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN)
if $PIECE(SDWLRNE,U,4)="A"
GOTO A1A
SET SDWLRNED=$PIECE(SDWLRNE,U,3)
Begin DoDot:1
+3 SET X=SDWLRNE
DO H^%DTC
+4 IF %H>SDWLODT
SET SDWLRNED=0
End DoDot:1
+5 IF SDWLRNED
SET (SDWLDAT,X)=SDWLRNED
DO H^%DTC
SET SDWLDS=%H
SET SDWLDE=SDWLODT
SET SDWLDET=SDWLDE-SDWLDS
SET SDWLDB=2
IF SDWLDET<366
SET SDWLE=1
+6 IF $DATA(SDWLDET)
IF SDWLDET>365
SET SDWLE=3
+7 IF 'SDWLRNE
SET SDWLE=4
A1A IF $DATA(SDWLRNE)
IF $PIECE(SDWLRNE,U,4)="A"
Begin DoDot:1
+1 IF $DATA(SDWLEE)
IF SDWLEE>730!(SDWLEE=730)
SET SDWLE=4
QUIT
+2 IF 'SDWLEE
SET SDWLE=4
QUIT
End DoDot:1
A1B QUIT
A2 ;GET TREATMENT DATE FROM VSSC FILE
+1 SET SDWLDTT=SDWLODX
SET SDWLDE=SDWLODT
SET SDWLDB=3
SET SDWLDAT=""
SET SDWLE=""
Begin DoDot:1
+2 IF '$DATA(^XTMP("SDWLFUL",$JOB,SDWLSSN,SDWLDTT))
QUIT
+3 SET SDWLTDT=+$GET(^XTMP("SDWLFUL",$JOB,SDWLSSN,SDWLDTT))
SET X=SDWLTDT
DO H^%DTC
IF %H'>SDWLODT
Begin DoDot:2
+4 SET SDWLDAT=SDWLTDT
SET SDWLEE=SDWLDE-%H
SET SDWLDB=3
IF SDWLEE<730
SET SDWLE=2
+5 IF $DATA(SDWLEE)
IF SDWLEE>730!(SDWLEE=730)
SET SDWLE=3
End DoDot:2
End DoDot:1
+6 QUIT
KILL SET DA=0
FOR
SET DA=$ORDER(^SDWL(409.39,DA))
if DA<1
QUIT
SET DIK="^SDWL(409.39,"
DO ^DIK
+1 QUIT
SETUP SET X=^DIC(409.39,0)
KILL ^SDWL(409.39)
SET ^SDWL(409.39,0)=X
+1 SET SDWLX=$ORDER(^XPD(9.7,"B","SD*5.3*485",999999999),-1)
+2 SET SDWLSDAT=+$PIECE(^XPD(9.7,SDWLX,0),"^",3)
+3 SET DAXT=$PIECE($GET(^SDWL(409.3,0)),U,4)
