ACDAUTO1.m

ACDAUTO1 ;IHS/ADC/EDE/KML - auto create client services for multiple dfn's; 

 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 ;;

 ;***********************************************************

 ;ACDVISP is set in the input template and must be defined

 ;when leaving the template and coming here. ACDVISP is the

 ;internal DA to ^ACDVIS for the original visit

 ;***********************************************************

EN ;EP Ask for clients to auto create 'CS' for

 ;//^ACDDE

 D MAIN

 D K

 Q

 ;

MAIN ;

 K ACDQUIT

 Q:'$G(ACDVISP)

 S ACDOPAT=$P(^ACDVIS(ACDVISP,0),U,5) ;   save patient IEN

 ;

 S:'$D(ACDLINE) $P(ACDLINE,"=",80)="="

 ;W @IOF,!,ACDLINE,!,*7,*7,*7

 W !!,ACDLINE,!

 I $G(ACDDECSN) D  I 1

 . W "Since you have created a new Client Service visit, I can now",!

 . W "automatically create an exact duplicate of it for you with",!

 . W "the visit and 'ALL' attached client service days but for",!

 . W "different patients you select.",!

 . Q

 E  D

 . W "Since you have added client service days to a Client Service",!

 . W "visit I can now automatically duplicate the client service days",!

 . W "for different patients you select.",!

 . Q

 W ACDLINE,!

 ;

DIR ;Ask for patients Category or Selected patients

 S DIR("A")="SELECTION",DIR(0)="S^1:SELECT A CATEGORY OF PATIENTS;3:EXIT" D ^DIR S:X["^"!($D(DTOUT))!(X="")!(X=3) ACDQUIT=1

 Q:$D(ACDQUIT)

 W !

 ;

 ;Ask for category of patients

 K ACDPT1

 S DIC=9002172.8,DIC(0)="AEQM",DIC("S")="I $P(^(0),U,3)=ACDCOMC,$P(^(0),U,4)=ACDCOMT,$P(^(0),U,2)=ACDPGM" D ^DIC

 G:Y<0 DIR

 I $D(^ACDPAT(+Y,1,0)) S ACDCATP=+Y F ACDA=0:0 S ACDA=$O(^ACDPAT(+Y,1,ACDA)) Q:'ACDA  I $D(^(ACDA,0)) S ACDPT1(ACDA)=""

 ;

EN1 ;Begin auto creation process of entries in ^ACDVIS

 Q:'$O(ACDPT1(0))

 W !!,"Auto creating visit nodes for:",!!

 F ACDDFNP=0:0 S ACDDFNP=$O(ACDPT1(ACDDFNP)) Q:'ACDDFNP  D

 . Q:ACDDFNP=ACDOPAT  ;   don't process original patient

 . W $P(^DPT(ACDDFNP,0),U),!

 . D CHKCSV ;             see if CS visit exists

 . I ACDVIEN S ACDPT1(ACDDFNP)=ACDVIEN Q

 . D GENCSV ;             go autoduplicate the CS visit

 . Q

 D CS ;                   go autoduplicate the CS entries

 Q

 ;

CHKCSV ; SEE IF CS VISIT EXISTS

 S ACDVIEN=0

 D GETVSITS^ACDDEU ;      gather up all visits for this patient

 S ACDY=0

 I $D(^TMP("ACD",$J,"VISITS",ACDVDTI)) S ACDY=0 F  S ACDY=$O(^TMP("ACD",$J,"VISITS",ACDVDTI,ACDY)) Q:'ACDY  D  Q:ACDQ

 . S X=^ACDVIS(ACDY,0)

 . I $P(X,U,2)=ACDCOMC,$P(X,U,7)=ACDCOMT,$P(X,U,4)="CS" S ACDQ=1 Q

 . Q

 S ACDQ=0

 I ACDY S ACDVIEN=ACDY Q  ;   CS visit exists

 Q

 ;

GENCSV ; AUTODUPLICATE CS VISIT

 D GENV ;              generate CS visit with .01 field only

 D DUPV ;              duplicate the rest of the CS visit

 D MODV ;              modify demographic part of CS visit

 ;Re-index new entry in ^ACDVIS to be safe

 S DA=ACDPT1(ACDDFNP)

 S DIK="^ACDVIS(" D IX1^DIK

 Q

 ;

GENV ; GENERATE VISIT NODE

 S X=$P(^ACDVIS(ACDVISP,0),U)

 S DIC="^ACDVIS("

 S DIC(0)="L"

 D FILE^ACDFMC

 ;Reset ACDPT1 array to form ACDPT1(DFN)=DA

 S ACDPT1(ACDDFNP)=+Y

 Q

 ;

DUPV ; DUPLICATE CS VISIT

 ;Duplicate the original visit from ^ACDVIS for new patient

 S %X="^ACDVIS("_ACDVISP_","

 S %Y="^ACDVIS("_ACDPT1(ACDDFNP)_","

 D %XY^%RCR

 Q

 ;

MODV ; MODIFY DEMOGRAPHIC PORTION OF VISIT JUST GENERATED

 D MODV^ACDAUTO3

 Q

 ;

CS ;Begin auto creation of entries in ^ACDCS

 ;

 W !!,"Auto creating Client Service nodes now for:"

 F ACDDFNP=0:0 S ACDDFNP=$O(ACDPT1(ACDDFNP)) Q:'ACDDFNP  D

 .Q:ACDDFNP=ACDOPAT  ;       quit if original patient

 .W !!,$P(^DPT(ACDDFNP,0),U)

 .F ACDCSORI=0:0 S ACDCSORI=$O(ACDCS(ACDCSORI)) Q:'ACDCSORI  D

 ..;

 ..;Set up new entry in ^ACDCS i.e. set up .01 field

 ..S X=$P(^ACDCS(ACDCSORI,0),U),ACDUPDT=X

 ..S DIC="^ACDCS("

 ..S DIC(0)="L"

 ..D FILE^ACDFMC S ACDNEWCS=+Y

 ..;

 ..I (ACDFHCP+ACDFPCC) S ACDPCCL(ACDDFNP,ACDPT1(ACDDFNP),"CS",ACDNEWCS)=""

 ..;

 ..;Duplicate the original entries in the client service file

 ..S %X="^ACDCS("_ACDCSORI_","

 ..S %Y="^ACDCS("_ACDNEWCS_","

 ..D %XY^%RCR

 ..;

 ..;Set up the^ACDCS 'BWP' to ^ACDVIS

 ..S DIE="^ACDCS("

 ..S DA=ACDNEWCS

 ..S DR="99.99////^S X=ACDPT1(ACDDFNP)"

 ..D DIE^ACDFMC

 ..;

 ..;Re-index new entry in ^ACDCS to be safe

 ..S DIK="^ACDCS(",DA=ACDNEWCS D IX1^DIK W ?35,"Client service day: ",ACDUPDT," being auto-created.",!

 W !!!,"Finished auto-creating.",!

 Q

 ;

K ;

 K ACDA,ACDCATP,ACDCSORI,ACDLINE,ACDNEWCS,ACDPT1,ACDUPDT,ACDXXX

 Q

ACDAUTO1  ;IHS/ADC/EDE/KML - auto create client services for multiple dfn's; 

 +1       ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 +2       ;;

 +3       ;***********************************************************

 +4       ;ACDVISP is set in the input template and must be defined

 +5       ;when leaving the template and coming here. ACDVISP is the

 +6       ;internal DA to ^ACDVIS for the original visit

 +7       ;***********************************************************

EN        ;EP Ask for clients to auto create 'CS' for

 +1       ;//^ACDDE

 +2        DO MAIN

 +3        DO K

 +4        QUIT 

 +5       ;

MAIN      ;

 +1        KILL ACDQUIT

 +2        IF '$GET(ACDVISP)

               QUIT 

 +3       ;   save patient IEN

           SET ACDOPAT=$PIECE(^ACDVIS(ACDVISP,0),U,5)

 +4       ;

 +5        IF '$DATA(ACDLINE)

               SET $PIECE(ACDLINE,"=",80)="="

 +6       ;W @IOF,!,ACDLINE,!,*7,*7,*7

 +7        WRITE !!,ACDLINE,!

 +8        IF $GET(ACDDECSN)

               Begin DoDot:1

 +9                WRITE "Since you have created a new Client Service visit, I can now",!

 +10               WRITE "automatically create an exact duplicate of it for you with",!

 +11               WRITE "the visit and 'ALL' attached client service days but for",!

 +12               WRITE "different patients you select.",!

 +13               QUIT 

               End DoDot:1

               IF 1

 +14      IF '$TEST

               Begin DoDot:1

 +15               WRITE "Since you have added client service days to a Client Service",!

 +16               WRITE "visit I can now automatically duplicate the client service days",!

 +17               WRITE "for different patients you select.",!

 +18               QUIT 

               End DoDot:1

 +19       WRITE ACDLINE,!

 +20      ;

DIR       ;Ask for patients Category or Selected patients

 +1        SET DIR("A")="SELECTION"

           SET DIR(0)="S^1:SELECT A CATEGORY OF PATIENTS;3:EXIT"

           DO ^DIR

           IF X["^"!($DATA(DTOUT))!(X="")!(X=3)

               SET ACDQUIT=1

 +2        IF $DATA(ACDQUIT)

               QUIT 

 +3        WRITE !

 +4       ;

 +5       ;Ask for category of patients

 +6        KILL ACDPT1

 +7        SET DIC=9002172.8

           SET DIC(0)="AEQM"

           SET DIC("S")="I $P(^(0),U,3)=ACDCOMC,$P(^(0),U,4)=ACDCOMT,$P(^(0),U,2)=ACDPGM"

           DO ^DIC

 +8        IF Y<0

               GOTO DIR

 +9        IF $DATA(^ACDPAT(+Y,1,0))

               SET ACDCATP=+Y

               FOR ACDA=0:0

                   SET ACDA=$ORDER(^ACDPAT(+Y,1,ACDA))

                   IF 'ACDA

                       QUIT 

                   IF $DATA(^(ACDA,0))

                       SET ACDPT1(ACDA)=""

 +10      ;

EN1       ;Begin auto creation process of entries in ^ACDVIS

 +1        IF '$ORDER(ACDPT1(0))

               QUIT 

 +2        WRITE !!,"Auto creating visit nodes for:",!!

 +3        FOR ACDDFNP=0:0

               SET ACDDFNP=$ORDER(ACDPT1(ACDDFNP))

               IF 'ACDDFNP

                   QUIT 

               Begin DoDot:1

 +4       ;   don't process original patient

                   IF ACDDFNP=ACDOPAT

                       QUIT 

 +5                WRITE $PIECE(^DPT(ACDDFNP,0),U),!

 +6       ;             see if CS visit exists

                   DO CHKCSV

 +7                IF ACDVIEN

                       SET ACDPT1(ACDDFNP)=ACDVIEN

                       QUIT 

 +8       ;             go autoduplicate the CS visit

                   DO GENCSV

 +9                QUIT 

               End DoDot:1

 +10      ;                   go autoduplicate the CS entries

           DO CS

 +11       QUIT 

 +12      ;

CHKCSV    ; SEE IF CS VISIT EXISTS

 +1        SET ACDVIEN=0

 +2       ;      gather up all visits for this patient

           DO GETVSITS^ACDDEU

 +3        SET ACDY=0

 +4        IF $DATA(^TMP("ACD",$JOB,"VISITS",ACDVDTI))

               SET ACDY=0

               FOR 

                   SET ACDY=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDVDTI,ACDY))

                   IF 'ACDY

                       QUIT 

                   Begin DoDot:1

 +5                    SET X=^ACDVIS(ACDY,0)

 +6                    IF $PIECE(X,U,2)=ACDCOMC

                           IF $PIECE(X,U,7)=ACDCOMT

                               IF $PIECE(X,U,4)="CS"

                                   SET ACDQ=1

                                   QUIT 

 +7                    QUIT 

                   End DoDot:1

                   IF ACDQ

                       QUIT 

 +8        SET ACDQ=0

 +9       ;   CS visit exists

           IF ACDY

               SET ACDVIEN=ACDY

               QUIT 

 +10       QUIT 

 +11      ;

GENCSV    ; AUTODUPLICATE CS VISIT

 +1       ;              generate CS visit with .01 field only

           DO GENV

 +2       ;              duplicate the rest of the CS visit

           DO DUPV

 +3       ;              modify demographic part of CS visit

           DO MODV

 +4       ;Re-index new entry in ^ACDVIS to be safe

 +5        SET DA=ACDPT1(ACDDFNP)

 +6        SET DIK="^ACDVIS("

           DO IX1^DIK

 +7        QUIT 

 +8       ;

GENV      ; GENERATE VISIT NODE

 +1        SET X=$PIECE(^ACDVIS(ACDVISP,0),U)

 +2        SET DIC="^ACDVIS("

 +3        SET DIC(0)="L"

 +4        DO FILE^ACDFMC

 +5       ;Reset ACDPT1 array to form ACDPT1(DFN)=DA

 +6        SET ACDPT1(ACDDFNP)=+Y

 +7        QUIT 

 +8       ;

DUPV      ; DUPLICATE CS VISIT

 +1       ;Duplicate the original visit from ^ACDVIS for new patient

 +2        SET %X="^ACDVIS("_ACDVISP_","

 +3        SET %Y="^ACDVIS("_ACDPT1(ACDDFNP)_","

 +4        DO %XY^%RCR

 +5        QUIT 

 +6       ;

MODV      ; MODIFY DEMOGRAPHIC PORTION OF VISIT JUST GENERATED

 +1        DO MODV^ACDAUTO3

 +2        QUIT 

 +3       ;

CS        ;Begin auto creation of entries in ^ACDCS

 +1       ;

 +2        WRITE !!,"Auto creating Client Service nodes now for:"

 +3        FOR ACDDFNP=0:0

               SET ACDDFNP=$ORDER(ACDPT1(ACDDFNP))

               IF 'ACDDFNP

                   QUIT 

               Begin DoDot:1

 +4       ;       quit if original patient

                   IF ACDDFNP=ACDOPAT

                       QUIT 

 +5                WRITE !!,$PIECE(^DPT(ACDDFNP,0),U)

 +6                FOR ACDCSORI=0:0

                       SET ACDCSORI=$ORDER(ACDCS(ACDCSORI))

                       IF 'ACDCSORI

                           QUIT 

                       Begin DoDot:2

 +7       ;

 +8       ;Set up new entry in ^ACDCS i.e. set up .01 field

 +9                        SET X=$PIECE(^ACDCS(ACDCSORI,0),U)

                           SET ACDUPDT=X

 +10                       SET DIC="^ACDCS("

 +11                       SET DIC(0)="L"

 +12                       DO FILE^ACDFMC

                           SET ACDNEWCS=+Y

 +13      ;

 +14                       IF (ACDFHCP+ACDFPCC)

                               SET ACDPCCL(ACDDFNP,ACDPT1(ACDDFNP),"CS",ACDNEWCS)=""

 +15      ;

 +16      ;Duplicate the original entries in the client service file

 +17                       SET %X="^ACDCS("_ACDCSORI_","

 +18                       SET %Y="^ACDCS("_ACDNEWCS_","

 +19                       DO %XY^%RCR

 +20      ;

 +21      ;Set up the^ACDCS 'BWP' to ^ACDVIS

 +22                       SET DIE="^ACDCS("

 +23                       SET DA=ACDNEWCS

 +24                       SET DR="99.99////^S X=ACDPT1(ACDDFNP)"

 +25                       DO DIE^ACDFMC

 +26      ;

 +27      ;Re-index new entry in ^ACDCS to be safe

 +28                       SET DIK="^ACDCS("

                           SET DA=ACDNEWCS

                           DO IX1^DIK

                           WRITE ?35,"Client service day: ",ACDUPDT," being auto-created.",!

                       End DoDot:2

               End DoDot:1

 +29       WRITE !!!,"Finished auto-creating.",!

 +30       QUIT 

 +31      ;

K         ;

 +1        KILL ACDA,ACDCATP,ACDCSORI,ACDLINE,ACDNEWCS,ACDPT1,ACDUPDT,ACDXXX

 +2        QUIT