- SDWLE11 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT - WAIT LIST TYPE/INSTUTITION;06/12/2002 ; 20 Aug 2002 2:10 PM ; Compiled May 25, 2007 16:20:20
- ;;5.3;scheduling;**263,485,497,446,1015**;AUG 13 1993;Build 21
- ;
- ;
- ;******************************************************************
- ; CHANGE LOG
- ;
- ; DATE PATCH DESCRIPTION
- ; ---- ----- -----------
- ; 05/09/2006 SD*5.3*485 CORRECT ENROLLMENT STATUS.
- ; 06/05/2006 SD*5.3*446 Scheduling reminder flag
- ;
- ;
- NEW ;ADD NEW PATIENT
- K DIC,DIR,DR,DIE N %H,SDWLDS,SDWLE,SDWLNEW,SDWLRNED,SDWLX,SDWLY
- S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN S (SDWLDA,DA)=+Y
- S SDWLNEW=1 K DIC
- L ^SDWL(409.3,SDWLDA)
- S DIE="^SDWL(409.3,",DR="1////^S X=DT"
- D:$G(SDWLACA) ; 446
- .W !,"Note: you are about to create an EWL entry to be used as a Scheduling Reminder."
- .S DR=DR_";33////^S X=""Y"""
- .Q
- D ^DIE
- ;
- ;DETERMINE ENROLLEE STATUS
- ;
- ;SDWLE=1 = NEW ENROLLEE
- ;SDWLE=2 = ESTABLISHED
- ;SDWLE=3 = PRIOR ENROLLEE
- ;SDWLE=4 = UNDETERMINED
- TST ;
- EN S SDWLDE=+$H,SDWLE=1,(SDWLEE,SDWLRNED,SDWLDB)=0 D SB1
- G SB0:SDWLE=2
- S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G SB0:$P(SDWLRNE,U,4)="A" S SDWLRNED=$P(SDWLRNE,U,3)
- I SDWLRNED S X=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=+$H,SDWLDET=SDWLDE-SDWLDS,SDWLDB=2 I SDWLDET<366 S SDWLE=1
- I $D(SDWLDET),SDWLDET>365 S SDWLE=3
- I 'SDWLRNE S SDWLE=4
- SB0 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
- S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
- ;-Code here for filling in 409.3
- S DR="27////^S X=SDWLRNE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
- ;SAVE ENROLLEE CALCULATION DATE
- S DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE
- ;SAVE DATABASE FILE
- S DR="27.2////^S X=SDWLDB" D ^DIE
- S DR="9////^S X=DUZ" D ^DIE
- K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,X
- Q
- SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) N SDWLDB S SDWLE=3 Q
- S SDWLX="" 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) I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
- ;FIND LAST TREATMENT DATE
- I '$D(SDWLDTF) Q
- S SDWLDTF=$O(SDWLDTF(0)) I SDWLDTF S (SDWLD,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
- END Q
- SDWLE11 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT - WAIT LIST TYPE/INSTUTITION;06/12/2002 ; 20 Aug 2002 2:10 PM ; Compiled May 25, 2007 16:20:20
- +1 ;;5.3;scheduling;**263,485,497,446,1015**;AUG 13 1993;Build 21
- +2 ;
- +3 ;
- +4 ;******************************************************************
- +5 ; CHANGE LOG
- +6 ;
- +7 ; DATE PATCH DESCRIPTION
- +8 ; ---- ----- -----------
- +9 ; 05/09/2006 SD*5.3*485 CORRECT ENROLLMENT STATUS.
- +10 ; 06/05/2006 SD*5.3*446 Scheduling reminder flag
- +11 ;
- +12 ;
- NEW ;ADD NEW PATIENT
- +1 KILL DIC,DIR,DR,DIE
- NEW %H,SDWLDS,SDWLE,SDWLNEW,SDWLRNED,SDWLX,SDWLY
- +2 SET DIC(0)="LX"
- SET X=SDWLDFN
- SET DIC="^SDWL(409.3,"
- DO FILE^DICN
- SET (SDWLDA,DA)=+Y
- +3 SET SDWLNEW=1
- KILL DIC
- +4 LOCK ^SDWL(409.3,SDWLDA)
- +5 SET DIE="^SDWL(409.3,"
- SET DR="1////^S X=DT"
- +6 ; 446
- IF $GET(SDWLACA)
- Begin DoDot:1
- +7 WRITE !,"Note: you are about to create an EWL entry to be used as a Scheduling Reminder."
- +8 SET DR=DR_";33////^S X=""Y"""
- +9 QUIT
- End DoDot:1
- +10 DO ^DIE
- +11 ;
- +12 ;DETERMINE ENROLLEE STATUS
- +13 ;
- +14 ;SDWLE=1 = NEW ENROLLEE
- +15 ;SDWLE=2 = ESTABLISHED
- +16 ;SDWLE=3 = PRIOR ENROLLEE
- +17 ;SDWLE=4 = UNDETERMINED
- TST ;
- EN SET SDWLDE=+$HOROLOG
- SET SDWLE=1
- SET (SDWLEE,SDWLRNED,SDWLDB)=0
- DO SB1
- +1 IF SDWLE=2
- GOTO SB0
- +2 SET SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN)
- IF $PIECE(SDWLRNE,U,4)="A"
- GOTO SB0
- SET SDWLRNED=$PIECE(SDWLRNE,U,3)
- +3 IF SDWLRNED
- SET X=SDWLRNED
- DO H^%DTC
- SET SDWLDS=%H
- SET SDWLDE=+$HOROLOG
- SET SDWLDET=SDWLDE-SDWLDS
- SET SDWLDB=2
- IF SDWLDET<366
- SET SDWLE=1
- +4 IF $DATA(SDWLDET)
- IF SDWLDET>365
- SET SDWLE=3
- +5 IF 'SDWLRNE
- SET SDWLE=4
- SB0 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
- +3 SET SDWLRNE=$SELECT(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
- +4 ;-Code here for filling in 409.3
- +5 SET DR="27////^S X=SDWLRNE"
- SET DIE="^SDWL(409.3,"
- SET DA=SDWLDA
- DO ^DIE
- +6 ;SAVE ENROLLEE CALCULATION DATE
- +7 SET DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")"
- DO ^DIE
- +8 ;SAVE DATABASE FILE
- +9 SET DR="27.2////^S X=SDWLDB"
- DO ^DIE
- +10 SET DR="9////^S X=DUZ"
- DO ^DIE
- +11 KILL SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,X
- +12 QUIT
- SB1 IF '$DATA(^DGCN(391.91,"B",SDWLDFN))
- NEW SDWLDB
- SET SDWLE=3
- QUIT
- +1 SET SDWLX=""
- FOR
- SET SDWLX=$ORDER(^DGCN(391.91,"B",SDWLDFN,SDWLX))
- IF SDWLX=""
- QUIT
- Begin DoDot:1
- +2 SET SDWLY=$GET(^DGCN(391.91,SDWLX,0))
- Begin DoDot:2
- +3 ;CHECK FOR VALID TF
- +4 IF $$TF^XUAF4(+$PIECE(SDWLY,U,2))
- Begin DoDot:3
- +5 ;GET LIST OF DATES FOR TF
- +6 SET SDWLD=$PIECE(SDWLY,U,3)
- IF SDWLD
- SET SDWLDTF(9999999-SDWLD)=SDWLX
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +7 ;FIND LAST TREATMENT DATE
- +8 IF '$DATA(SDWLDTF)
- QUIT
- +9 SET SDWLDTF=$ORDER(SDWLDTF(0))
- IF SDWLDTF
- SET (SDWLD,X)=9999999-SDWLDTF
- DO H^%DTC
- SET SDWLEE=SDWLDE-%H
- SET SDWLDB=1
- IF SDWLEE<730
- SET SDWLE=2
- +10 IF $DATA(SDWLEE)
- IF SDWLEE>730!(SDWLEE=730)
- SET SDWLE=3
- +11 KILL SDWLDTF
- END QUIT
