Routine: DGENACL2

DGENACL2 ;ALB/MRY - NEW ENROLLEE APPOINTMENT CALL LIST - UPDATE ;08/14/2008

 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20

EXTRACT ;

 N DGNAM,DGSSN,DGENRIEN,DGENR,DGENCAT,DGENSTA,DGSTA1,DGENPRI,DGENCV,DGENCVDT,DGENCVEL,DGCOM,DGPFSITE

 N SDCNT,SDADT,SDARRY,SDCL,Y,FDATA,SDEXIT,DGRDTI,DGSTA

 ;get preferred facility

 S DGPFSITE=$$GET1^DIQ(4,+$$GET1^DIQ(2,DFNIEN,27.02,"I"),99)

 S DGPFTF=$S(+$$GET1^DIQ(2,DFNIEN,27.02,"I"):$$GET1^DIQ(2,DFNIEN,27.02,"I"),1:"NULL")

 I +DGSITE'=+DGPFSITE Q  ;if not same division skip

 I DGPFTFLG=1,'$D(DGPFTF(DGPFTF)) Q  ;selection of preferred facilities

 ;get enrollment information

 S DGENRIEN=$$FINDCUR^DGENA(DFNIEN)

 I DGENRIEN,$$GET^DGENA(DGENRIEN,.DGENR) ;set-up enrollment arry

 I $G(DGENR("APP"))<3050801 Q

 S DGENCAT=$$CATEGORY^DGENA4(,$G(DGENR("STATUS"))) ;enrollment category

 I DGENCAT'="E" Q

 S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)

 S DGENSTA=$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"")

 S DGENPRI=$S($G(DGENR("PRIORITY")):DGENR("PRIORITY"),1:"")_$S($G(DGENR("SUBGRP")):$$EXT^DGENU("SUBGRP",DGENR("SUBGRP")),1:"")

 D APPTCK ;check appts.

 I +DGERROR Q  ;RSA API error

 I SDEXIT Q  ;quit if appointment < 'date notified of request date'.

 ;if call list, quit if request status 'filled' or 'completed'.

 I DGRPT=1 Q:(SDCNT>0)!(DGSTA="C")!(DGSTA="F")

 S SDADT=$G(SDADT)

 S DGNAM=$$GET1^DIQ(2,DFNIEN,.01),DGSSN=$E($$GET1^DIQ(2,DFNIEN,.09),6,9)

 S DGENCV=$$CVEDT^DGCV(DFNIEN),DGENCVDT=$P($G(DGENCV),"^",2),DGENCVEL=$P($G(DGENCV),"^",3)

 ;build temp file

 S DGPFTF=$S(+DGPFTF:$$GET1^DIQ(4,DGPFTF,.01)_"("_DGPFSITE_")",1:"ZZZZZ")

 S DGSTA1=$S(DGSTA="":1,DGSTA="I":2,DGSTA="E":3,DGSTA="F":4,1:DGSTA)

 S ^TMP($J,"DGEN NEACL",DGPFTF,DGSTA1,DGRDTI,DGNAM,DFNIEN)=SDADT

 I $G(DGENCAT)'=""!($G(DGENSTA)'="")!($G(DGENPRI)'="")!($G(DGENCVEL)'="") D

 . S ^TMP($J,"DGEN NEACL",DGPFTF,DGSTA1,DGRDTI,DGNAM,DFNIEN,"PRIORITY")=DGENCAT_"^"_DGENSTA_"^"_DGENPRI_"^"_DGENCVEL

APPTCK ;

 ;quit, if no appointment questioned asked?

 S DGRDTI=$$GET1^DIQ(2,DFNIEN,1010.1511,"I") I 'DGRDTI S SDEXIT=1 Q

 ;get request status

 S DGSTA=$$GET1^DIQ(2,DFNIEN,1010.161,"I")

 ;look for any appointments made (quit if none, or appt. date < 'notify of request date'

 K ^TMP($J,"SDAMA301")

 S SDARRY(4)=DFNIEN

 S SDARRY("FLDS")=1

 S SDARRY("MAX")=1

 S SDEXIT=0

 S SDCNT=$$SDAPI^SDAMA301(.SDARRY) I SDCNT<0 S DGERROR=$$ERR() Q

 Q:(SDCNT'>0)  ;no appointment

 ;quit if appointment < 'notify of request date'

 S SDCL=0 F  S SDCL=$O(^TMP($J,"SDAMA301",DFNIEN,SDCL)) Q:'SDCL  D  I SDEXIT=1 Q

 . I $O(^TMP($J,"SDAMA301",DFNIEN,SDCL,0))<DGRDTI S SDEXIT=1

 K ^TMP($J,"SDAMA301")

 ;Check appointments (scheduled/kept, inpatient, no action)

 S SDARRY(1)=DGRDTI_";" ;look out from 'notify of request date' to future.

 S SDARRY(3)="R;I;NT"

 S SDARRY(4)=DFNIEN,SDARRY("FLDS")=1

 S SDCNT=$$SDAPI^SDAMA301(.SDARRY) Q:(SDCNT'>0)

 ;Exclude no count clinic appointments from appointment count

 N SDCOUNT

 S SDCOUNT=0 ;count clinic

 S SDCL=0 F  S SDCL=$O(^TMP($J,"SDAMA301",DFNIEN,SDCL)) Q:'SDCL  D  Q:SDCOUNT

 . I $$GET1^DIQ(44,SDCL,2502,"I")="Y" Q  ;don't include no-count

 . S SDADT=$O(^TMP($J,"SDAMA301",DFNIEN,SDCL,0)) ;get appointment date of count clinic

 . S SDCOUNT=SDCOUNT+1

 I SDCOUNT=0 S SDCNT=0 Q  ;if no-count clinics was only one found, keep on call list.

 ;if appointment found and status '="filled", set status to 'filled'

 I DGSTA'="F" D

 . S DGCOM=$$GET1^DIQ(2,DFNIEN,1010.163)

 . S DGCOM=DGCOM_$S(DGCOM'="":"<>",1:"")_"AutoComm:"_$S(DGSTA="":"null",1:$S($$GET1^DIQ(2,DFNIEN,1010.161,"I")="I":"IN PROGRESS",1:$$GET1^DIQ(2,DFNIEN,1010.161)))_"|FILLED"

 . S FDATA(2,DFNIEN_",",1010.161)="F"

 . S FDATA(2,DFNIEN_",",1010.163)=DGCOM

 . D FILE^DIE("","FDATA","DPTERR")

 . S DGSTA=$$GET1^DIQ(2,DFNIEN,1010.161,"I")

ERR() ; Process error message.

 N DGERR

 S DGERR=0

 I $D(^TMP($J,"SDAMA301",101)) D

 . S DGERR=101_"^"_"  *** RSA: Process DATABASE IS UNAVAILABLE ***"

 I $D(^TMP($J,"SDAMA301",115)) D

 . S DGERR=115_"^"_"  *** RSA: Appointment request filter contains invalid values ***"

 I $D(^TMP($J,"SDAMA301",116)) D

 . S DGERR=116_"^"_"  *** RSA: Data doesn't exist error has occurred ***"

 I $D(^TMP($J,"SDAMA301",117)) D

 . S DGERR=117_"^"_"  *** RSA: Other undefined error has occurred ***"

 Q DGERR

DGENACL2  ;ALB/MRY - NEW ENROLLEE APPOINTMENT CALL LIST - UPDATE ;08/14/2008

 +1       ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20

 +2       ;

EXTRACT   ;

 +1        NEW DGNAM,DGSSN,DGENRIEN,DGENR,DGENCAT,DGENSTA,DGSTA1,DGENPRI,DGENCV,DGENCVDT,DGENCVEL,DGCOM,DGPFSITE

 +2        NEW SDCNT,SDADT,SDARRY,SDCL,Y,FDATA,SDEXIT,DGRDTI,DGSTA

 +3       ;get preferred facility

 +4        SET DGPFSITE=$$GET1^DIQ(4,+$$GET1^DIQ(2,DFNIEN,27.02,"I"),99)

 +5        SET DGPFTF=$SELECT(+$$GET1^DIQ(2,DFNIEN,27.02,"I"):$$GET1^DIQ(2,DFNIEN,27.02,"I"),1:"NULL")

 +6       ;if not same division skip

           IF +DGSITE'=+DGPFSITE

               QUIT

 +7       ;selection of preferred facilities

           IF DGPFTFLG=1

               IF '$DATA(DGPFTF(DGPFTF))

                   QUIT

 +8       ;get enrollment information

 +9        SET DGENRIEN=$$FINDCUR^DGENA(DFNIEN)

 +10      ;set-up enrollment arry

           IF DGENRIEN

               IF $$GET^DGENA(DGENRIEN,.DGENR)

 +11       IF $GET(DGENR("APP"))<3050801

               QUIT

 +12      ;enrollment category

           SET DGENCAT=$$CATEGORY^DGENA4(,$GET(DGENR("STATUS")))

 +13       IF DGENCAT'="E"

               QUIT

 +14       SET DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)

 +15       SET DGENSTA=$SELECT($GET(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"")

 +16       SET DGENPRI=$SELECT($GET(DGENR("PRIORITY")):DGENR("PRIORITY"),1:"")_$SELECT($GET(DGENR("SUBGRP")):$$EXT^DGENU("SUBGRP",DGENR("SUBGRP")),1:"")

 +17      ;check appts.

           DO APPTCK

 +18      ;RSA API error

           IF +DGERROR

               QUIT

 +19      ;quit if appointment < 'date notified of request date'.

           IF SDEXIT

               QUIT

 +20      ;if call list, quit if request status 'filled' or 'completed'.

 +21       IF DGRPT=1

               IF (SDCNT>0)!(DGSTA="C")!(DGSTA="F")

                   QUIT

 +22       SET SDADT=$GET(SDADT)

 +23       SET DGNAM=$$GET1^DIQ(2,DFNIEN,.01)

           SET DGSSN=$EXTRACT($$GET1^DIQ(2,DFNIEN,.09),6,9)

 +24       SET DGENCV=$$CVEDT^DGCV(DFNIEN)

           SET DGENCVDT=$PIECE($GET(DGENCV),"^",2)

           SET DGENCVEL=$PIECE($GET(DGENCV),"^",3)

 +25      ;build temp file

 +26       SET DGPFTF=$SELECT(+DGPFTF:$$GET1^DIQ(4,DGPFTF,.01)_"("_DGPFSITE_")",1:"ZZZZZ")

 +27       SET DGSTA1=$SELECT(DGSTA="":1,DGSTA="I":2,DGSTA="E":3,DGSTA="F":4,1:DGSTA)

 +28       SET ^TMP($JOB,"DGEN NEACL",DGPFTF,DGSTA1,DGRDTI,DGNAM,DFNIEN)=SDADT

 +29       IF $GET(DGENCAT)'=""!($GET(DGENSTA)'="")!($GET(DGENPRI)'="")!($GET(DGENCVEL)'="")

               Begin DoDot:1

 +30               SET ^TMP($JOB,"DGEN NEACL",DGPFTF,DGSTA1,DGRDTI,DGNAM,DFNIEN,"PRIORITY")=DGENCAT_"^"_DGENSTA_"^"_DGENPRI_"^"_DGENCVEL

               End DoDot:1

 +31       QUIT

 +32      ;

APPTCK    ;

 +1       ;quit, if no appointment questioned asked?

 +2        SET DGRDTI=$$GET1^DIQ(2,DFNIEN,1010.1511,"I")

           IF 'DGRDTI

               SET SDEXIT=1

               QUIT

 +3       ;get request status

 +4        SET DGSTA=$$GET1^DIQ(2,DFNIEN,1010.161,"I")

 +5       ;look for any appointments made (quit if none, or appt. date < 'notify of request date'

 +6        KILL ^TMP($JOB,"SDAMA301")

 +7        SET SDARRY(4)=DFNIEN

 +8        SET SDARRY("FLDS")=1

 +9        SET SDARRY("MAX")=1

 +10       SET SDEXIT=0

 +11       SET SDCNT=$$SDAPI^SDAMA301(.SDARRY)

           IF SDCNT<0

               SET DGERROR=$$ERR()

               QUIT

 +12      ;no appointment

           IF (SDCNT'>0)

               QUIT

 +13      ;quit if appointment < 'notify of request date'

 +14       SET SDCL=0

FOR

               SET SDCL=$ORDER(^TMP($JOB,"SDAMA301",DFNIEN,SDCL))

               IF 'SDCL

                   QUIT

               Begin DoDot:1

 +15               IF $ORDER(^TMP($JOB,"SDAMA301",DFNIEN,SDCL,0))<DGRDTI

                       SET SDEXIT=1

               End DoDot:1

               IF SDEXIT=1

                   QUIT

 +16      ;

 +17       KILL ^TMP($JOB,"SDAMA301")

 +18      ;Check appointments (scheduled/kept, inpatient, no action)

 +19      ;look out from 'notify of request date' to future.

           SET SDARRY(1)=DGRDTI_";"

 +20       SET SDARRY(3)="R;I;NT"

 +21       SET SDARRY(4)=DFNIEN

           SET SDARRY("FLDS")=1

 +22       SET SDCNT=$$SDAPI^SDAMA301(.SDARRY)

           IF (SDCNT'>0)

               QUIT

 +23      ;Exclude no count clinic appointments from appointment count

 +24       NEW SDCOUNT

 +25      ;count clinic

           SET SDCOUNT=0

 +26       SET SDCL=0

FOR

               SET SDCL=$ORDER(^TMP($JOB,"SDAMA301",DFNIEN,SDCL))

               IF 'SDCL

                   QUIT

               Begin DoDot:1

 +27      ;don't include no-count

                   IF $$GET1^DIQ(44,SDCL,2502,"I")="Y"

                       QUIT

 +28      ;get appointment date of count clinic

                   SET SDADT=$ORDER(^TMP($JOB,"SDAMA301",DFNIEN,SDCL,0))

 +29               SET SDCOUNT=SDCOUNT+1

               End DoDot:1

               IF SDCOUNT

                   QUIT

 +30      ;if no-count clinics was only one found, keep on call list.

           IF SDCOUNT=0

               SET SDCNT=0

               QUIT

 +31      ;if appointment found and status '="filled", set status to 'filled'

 +32       IF DGSTA'="F"

               Begin DoDot:1

 +33               SET DGCOM=$$GET1^DIQ(2,DFNIEN,1010.163)

 +34               SET DGCOM=DGCOM_$SELECT(DGCOM'="":"<>",1:"")_"AutoComm:"_$SELECT(DGSTA="":"null",1:$SELECT($$GET1^DIQ(2,DFNIEN,1010.161,"I")="I":"IN PROGRESS",1:$$GET1^DIQ(2,DFNIEN,1010.161)))_"|FILLED"

 +35               SET FDATA(2,DFNIEN_",",1010.161)="F"

 +36               SET FDATA(2,DFNIEN_",",1010.163)=DGCOM

 +37               DO FILE^DIE("","FDATA","DPTERR")

 +38               SET DGSTA=$$GET1^DIQ(2,DFNIEN,1010.161,"I")

               End DoDot:1

 +39       QUIT

ERR()     ; Process error message.

 +1        NEW DGERR

 +2        SET DGERR=0

 +3        IF $DATA(^TMP($JOB,"SDAMA301",101))

               Begin DoDot:1

 +4                SET DGERR=101_"^"_"  *** RSA: Process DATABASE IS UNAVAILABLE ***"

               End DoDot:1

 +5        IF $DATA(^TMP($JOB,"SDAMA301",115))

               Begin DoDot:1

 +6                SET DGERR=115_"^"_"  *** RSA: Appointment request filter contains invalid values ***"

               End DoDot:1

 +7        IF $DATA(^TMP($JOB,"SDAMA301",116))

               Begin DoDot:1

 +8                SET DGERR=116_"^"_"  *** RSA: Data doesn't exist error has occurred ***"

               End DoDot:1

 +9        IF $DATA(^TMP($JOB,"SDAMA301",117))

               Begin DoDot:1

 +10               SET DGERR=117_"^"_"  *** RSA: Other undefined error has occurred ***"

               End DoDot:1

 +11       QUIT DGERR

DGENACL2.m