- 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 Feb 19, 2025@00:29:09 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)
