ACDDE3C.m

ACDDE3C ;IHS/ADC/EDE/KML - COPY SET FOR CLIENT SERVICES; 

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

GENCSM ; EP - MAIN

 N ACDQ,ACDY

 ;//^ACDDE3B

 K ACDCSCS

 S DIR(0)="S^1:Create New Group;2:Edit Existing Group" S DIR("B")="2" K DA D ^DIR K DIR

 Q:'Y

 S ACDY=Y

 S ACDCSPGM=$S(ACDY=1:"^ACDCSCS",1:"GENCSMGC")

 D @ACDCSPGM Q:ACDQ

 D GENCSM2

 K ACDCSCS,ACDCSP

 Q

 ;

GENCSM2 ; GENERATE A COPY SET OF CLIENT SVCS

 D GENCSMCH ;          check copy set for changes

 Q:ACDQ  ;             quit if not good copy set

 D GENCSMCK ;          check copy set for required entries

 Q:ACDQ  ;             quit if not good copy set

 D GENCSMGR ;          generate CS records for copy set

 Q

 ;

GENCSMGC ; GET COPY SET

 S ACDQ=1

 W !

 S DIC="^ACDCSCS(",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,2)=ACDPGM"

 D DIC^ACDFMC

 Q:Y<0

 S ACDCSCS=+Y

 S ACDQ=0

 Q

 ;

GENCSMCH ; CHECK COPY SET FOR CHANGES

 S ACDQ=0

 ; place copy set into acdcscs array

 S X=^ACDCSCS(ACDCSCS,0)

 S ACDCSCS(.01)=$P(X,U),X=$P(X,U,3),ACDCSCS(.03)=X D PFTV^XBPFTV(9002170.8,X,.Z) S ACDCSCS(.03,Z)=""

 S Y=0 F ACDY=1:1 S Y=$O(^ACDCSCS(ACDCSCS,11,Y)) Q:'Y  S X=^(Y,0) D

 . S ACDCSCS(ACDY,.01)=$P(X,U),ACDCSCS(ACDY,.02)=$P(X,U,2) D PFTV^XBPFTV(9002170.6,$P(X,U),.Z) S ACDCSCS(ACDY,.01,Z)=""

 .;F ACDY2=0:0 S ACDY2=$O(^ACDCSCS(ACDCSCS,11,Y,11,ACDY2)) Q:'ACDY2  S X=^(ACDY2,0),ACDCSCS(ACDY,1100,ACDY2)=$P(X,U) D PFTV^XBPFTV(6,$P(X,U),.Z) S ACDCSCS(ACDY,1100,ACDY2,Z)=""

 . F ACDY2=0:0 S ACDY2=$O(^ACDCSCS(ACDCSCS,11,Y,11,ACDY2)) Q:'ACDY2  S X=^(ACDY2,0),ACDCSCS(ACDY,1100,ACDY2)=$P(X,U),Z=$P($G(^VA(200,$P(X,U),0)),U) S:Z="" Z=$P(X,U) S ACDCSCS(ACDY,1100,ACDY2,Z)=""

 . Q

 ;

 W ! S DIC="^ACDCSCS(",DA=ACDCSCS D DIQ^ACDFMC,PAUSE^ACDDEU

 W ! S DIR(0)="Y",DIR("A")="Accept copy set as is",DIR("B")="Y" K DA D ^DIR K DIR

 Q:Y  ;                 quit if ok as is

 W ! S DIR(0)="9002172.7,.03",DIR("B")=$O(ACDCSCS(.03,"")) K DA D ^DIR K DIR

 Q:Y["^"

 I +Y'=ACDCSCS(.03) K ACDCSCS(.03) S ACDCSCS(.03)=+Y,ACDCSCS(.03,Y(0,0))=""

 W ! F ACDY=1:1 Q:'$D(ACDCSCS(ACDY))  S X=$O(ACDCSCS(ACDY,.01,"")) W !,"SVC/ACT: ",X,?41,"HOURS: ",ACDCSCS(ACDY,.02),! D  D GENCSMED

 . F ACDY2=1:1 Q:'$D(ACDCSCS(ACDY,1100,ACDY2))  S X=$O(ACDCSCS(ACDY,1100,ACDY2,"")) W ?5,"PROVIDER: ",X,!

 . Q

 Q

 ;

GENCSMCK ; CHECK COPY SET FOR REQUIRED ENTRIES

 I '$O(ACDCSCS(.99)) S ACDQ=2 W !,IORVON,"No Client Services in Copy Set",IORVOFF,! D PAUSE^ACDDEU Q

 F Y=.99:0 S Y=$O(ACDCSCS(Y)) Q:'Y  I '$O(ACDCSCS(Y,1100,0)) S ACDQ=2,Z=$O(ACDCSCS(Y,.01,"")) W !,IORVON,"No Providers for svc/act ",Z,IORVOFF,!

 D:ACDQ PAUSE^ACDDEU

 Q

 ;

GENCSMED ; EDIT COPY SET

 S DIR(0)="S^1:Accept Client Service;2:Edit Client Service;3:Delete Client Service",DIR("B")="1" K DA D ^DIR K DIR

 W !

 Q:Y=1  ;                     quit if accepted

 I Y=3 K ACDCSCS(ACDY) Q  ;   Delete CS and quit

 ; must be 2 (Edit Client Service)

 S DIR(0)="9002172.711,.01",DIR("B")=$O(ACDCSCS(ACDY,.01,"")) K DA D ^DIR K DIR

 I +Y'=ACDCSCS(ACDY,.01) K ACDCSCS(ACDY,.01) S ACDCSCS(ACDY,.01)=+Y,ACDCSCS(ACDY,.01,Y(0,0))=""

 S DIR(0)="9002172.711,.02",DIR("B")=ACDCSCS(ACDY,.02) K DA D ^DIR K DIR

 I +Y'=ACDCSCS(ACDY,.02) K ACDCSCS(ACDY,.02) S ACDCSCS(ACDY,.02)=+Y

 ;

 F ACDY2=1:1 Q:'$D(ACDCSCS(ACDY,1100,ACDY2))  S DIR(0)="9002172.71111,.01",DIR("B")=$O(ACDCSCS(ACDY,1100,ACDY2,"")) K DA D ^DIR K DIR D

 . I $E(X)="@" K ACDCSCS(ACDY,1100,ACDY2) Q

 . I +Y'=ACDCSCS(ACDY,1100,ACDY2) K ACDCSCS(ACDY,1100,ACDY2) S ACDCSCS(ACDY,1100,ACDY2)=+Y,ACDCSCS(ACDY,1100,ACDY2,Y(0,0))=""

 . Q

 F ACDY2=ACDY2:1 D  Q:'Y

 . S DIR(0)="9002172.71111,.01" K DA D ^DIR K DIR

 . Q:'+Y

 . S ACDCSCS(ACDY,1100,ACDY2)=+Y,ACDCSCS(ACDY,1100,ACDY2,Y(0,0))=""

 . Q

 W !

 Q

 ;

GENCSMGR ; GENERATE CS RECORDS FOR COPY SET

 S ACDCSP=$P(^DD(9002172,100,0),U,2)

 S DIR(0)="9002172,.01" K DA D ^DIR K DIR

 I +Y<1!(+Y>31) S ACDQ=1 Q

 S ACDCSDAY=+Y

 W !

 F ACDY=.99:0 S ACDY=$O(ACDCSCS(ACDY)) Q:'ACDY  D  Q:ACDQ

 . S X=$O(ACDCSCS(ACDY,.01,"")) W "Adding CS ",X,!

 . S DIC="^ACDCS(",DIC(0)="L",DLAYGO=9002172,X=ACDCSDAY

 . S DIC("DR")="1////"_ACDCSCS(ACDY,.01)_";2////"_ACDCSCS(.03)_";3////"_ACDCSCS(ACDY,.02)_";7////"_DUZ_";99.99////"_ACDVIEN

 . D FILE^ACDFMC

 . I Y<0 W !,IORVON,"Creation of CDMIS CLIENT SVCS record failed.  Notify programmer.",IORVOFF,!! S ACDQ=1 S:$D(^%ZOSF("$ZE")) X="CDMIS CLIENT SVCS",@^("$ZE") D @^%ZOSF("ERRTN") D PAUSE^ACDDEU Q

 . S ACDCS(+Y)=""

 . S ACDCSIEN=+Y

 . F ACDY2=0:0 S ACDY2=$O(ACDCSCS(ACDY,1100,ACDY2)) Q:'ACDY2  D  Q:ACDQ

 .. S DIC="^ACDCS("_ACDCSIEN_",1,",DIC(0)="L",DIC("P")=ACDCSP,DA(1)=ACDY

 .. S X=ACDCSCS(ACDY,1100,ACDY2)

 .. D FILE^ACDFMC

 .. I Y<0 W !,IORVON,"Addition of provider to CLIENT SVCS record failed.  Notify programmer.",IORVOFF,!! S ACDQ=1 S:$D(^%ZOSF("$ZE")) X="CDMIS CLIENT SVCS PROVIDER",@^("$ZE") D @^%ZOSF("ERRTN") D PAUSE^ACDDEU Q

 .. Q

 . Q

 K ACDCSDAY,ACDCSIEN,ACDCSP

 Q

ACDDE3C   ;IHS/ADC/EDE/KML - COPY SET FOR CLIENT SERVICES; 

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

GENCSM    ; EP - MAIN

 +1        NEW ACDQ,ACDY

 +2       ;//^ACDDE3B

 +3        KILL ACDCSCS

 +4        SET DIR(0)="S^1:Create New Group;2:Edit Existing Group"

           SET DIR("B")="2"

           KILL DA

           DO ^DIR

           KILL DIR

 +5        IF 'Y

               QUIT 

 +6        SET ACDY=Y

 +7        SET ACDCSPGM=$SELECT(ACDY=1:"^ACDCSCS",1:"GENCSMGC")

 +8        DO @ACDCSPGM

           IF ACDQ

               QUIT 

 +9        DO GENCSM2

 +10       KILL ACDCSCS,ACDCSP

 +11       QUIT 

 +12      ;

GENCSM2   ; GENERATE A COPY SET OF CLIENT SVCS

 +1       ;          check copy set for changes

           DO GENCSMCH

 +2       ;             quit if not good copy set

           IF ACDQ

               QUIT 

 +3       ;          check copy set for required entries

           DO GENCSMCK

 +4       ;             quit if not good copy set

           IF ACDQ

               QUIT 

 +5       ;          generate CS records for copy set

           DO GENCSMGR

 +6        QUIT 

 +7       ;

GENCSMGC  ; GET COPY SET

 +1        SET ACDQ=1

 +2        WRITE !

 +3        SET DIC="^ACDCSCS("

           SET DIC(0)="AEMQ"

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

 +4        DO DIC^ACDFMC

 +5        IF Y<0

               QUIT 

 +6        SET ACDCSCS=+Y

 +7        SET ACDQ=0

 +8        QUIT 

 +9       ;

GENCSMCH  ; CHECK COPY SET FOR CHANGES

 +1        SET ACDQ=0

 +2       ; place copy set into acdcscs array

 +3        SET X=^ACDCSCS(ACDCSCS,0)

 +4        SET ACDCSCS(.01)=$PIECE(X,U)

           SET X=$PIECE(X,U,3)

           SET ACDCSCS(.03)=X

           DO PFTV^XBPFTV(9002170.8,X,.Z)

           SET ACDCSCS(.03,Z)=""

 +5        SET Y=0

           FOR ACDY=1:1

               SET Y=$ORDER(^ACDCSCS(ACDCSCS,11,Y))

               IF 'Y

                   QUIT 

               SET X=^(Y,0)

               Begin DoDot:1

 +6                SET ACDCSCS(ACDY,.01)=$PIECE(X,U)

                   SET ACDCSCS(ACDY,.02)=$PIECE(X,U,2)

                   DO PFTV^XBPFTV(9002170.6,$PIECE(X,U),.Z)

                   SET ACDCSCS(ACDY,.01,Z)=""

 +7       ;F ACDY2=0:0 S ACDY2=$O(^ACDCSCS(ACDCSCS,11,Y,11,ACDY2)) Q:'ACDY2  S X=^(ACDY2,0),ACDCSCS(ACDY,1100,ACDY2)=$P(X,U) D PFTV^XBPFTV(6,$P(X,U),.Z) S ACDCSCS(ACDY,1100,ACDY2,Z)=""

 +8                FOR ACDY2=0:0

                       SET ACDY2=$ORDER(^ACDCSCS(ACDCSCS,11,Y,11,ACDY2))

                       IF 'ACDY2

                           QUIT 

                       SET X=^(ACDY2,0)

                       SET ACDCSCS(ACDY,1100,ACDY2)=$PIECE(X,U)

                       SET Z=$PIECE($GET(^VA(200,$PIECE(X,U),0)),U)

                       IF Z=""

                           SET Z=$PIECE(X,U)

                       SET ACDCSCS(ACDY,1100,ACDY2,Z)=""

 +9                QUIT 

               End DoDot:1

 +10      ;

 +11       WRITE !

           SET DIC="^ACDCSCS("

           SET DA=ACDCSCS

           DO DIQ^ACDFMC

           DO PAUSE^ACDDEU

 +12       WRITE !

           SET DIR(0)="Y"

           SET DIR("A")="Accept copy set as is"

           SET DIR("B")="Y"

           KILL DA

           DO ^DIR

           KILL DIR

 +13      ;                 quit if ok as is

           IF Y

               QUIT 

 +14       WRITE !

           SET DIR(0)="9002172.7,.03"

           SET DIR("B")=$ORDER(ACDCSCS(.03,""))

           KILL DA

           DO ^DIR

           KILL DIR

 +15       IF Y["^"

               QUIT 

 +16       IF +Y'=ACDCSCS(.03)

               KILL ACDCSCS(.03)

               SET ACDCSCS(.03)=+Y

               SET ACDCSCS(.03,Y(0,0))=""

 +17       WRITE !

           FOR ACDY=1:1

               IF '$DATA(ACDCSCS(ACDY))

                   QUIT 

               SET X=$ORDER(ACDCSCS(ACDY,.01,""))

               WRITE !,"SVC/ACT: ",X,?41,"HOURS: ",ACDCSCS(ACDY,.02),!

               Begin DoDot:1

 +18               FOR ACDY2=1:1

                       IF '$DATA(ACDCSCS(ACDY,1100,ACDY2))

                           QUIT 

                       SET X=$ORDER(ACDCSCS(ACDY,1100,ACDY2,""))

                       WRITE ?5,"PROVIDER: ",X,!

 +19               QUIT 

               End DoDot:1

               DO GENCSMED

 +20       QUIT 

 +21      ;

GENCSMCK  ; CHECK COPY SET FOR REQUIRED ENTRIES

 +1        IF '$ORDER(ACDCSCS(.99))

               SET ACDQ=2

               WRITE !,IORVON,"No Client Services in Copy Set",IORVOFF,!

               DO PAUSE^ACDDEU

               QUIT 

 +2        FOR Y=.99:0

               SET Y=$ORDER(ACDCSCS(Y))

               IF 'Y

                   QUIT 

               IF '$ORDER(ACDCSCS(Y,1100,0))

                   SET ACDQ=2

                   SET Z=$ORDER(ACDCSCS(Y,.01,""))

                   WRITE !,IORVON,"No Providers for svc/act ",Z,IORVOFF,!

 +3        IF ACDQ

               DO PAUSE^ACDDEU

 +4        QUIT 

 +5       ;

GENCSMED  ; EDIT COPY SET

 +1        SET DIR(0)="S^1:Accept Client Service;2:Edit Client Service;3:Delete Client Service"

           SET DIR("B")="1"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        WRITE !

 +3       ;                     quit if accepted

           IF Y=1

               QUIT 

 +4       ;   Delete CS and quit

           IF Y=3

               KILL ACDCSCS(ACDY)

               QUIT 

 +5       ; must be 2 (Edit Client Service)

 +6        SET DIR(0)="9002172.711,.01"

           SET DIR("B")=$ORDER(ACDCSCS(ACDY,.01,""))

           KILL DA

           DO ^DIR

           KILL DIR

 +7        IF +Y'=ACDCSCS(ACDY,.01)

               KILL ACDCSCS(ACDY,.01)

               SET ACDCSCS(ACDY,.01)=+Y

               SET ACDCSCS(ACDY,.01,Y(0,0))=""

 +8        SET DIR(0)="9002172.711,.02"

           SET DIR("B")=ACDCSCS(ACDY,.02)

           KILL DA

           DO ^DIR

           KILL DIR

 +9        IF +Y'=ACDCSCS(ACDY,.02)

               KILL ACDCSCS(ACDY,.02)

               SET ACDCSCS(ACDY,.02)=+Y

 +10      ;

 +11       FOR ACDY2=1:1

               IF '$DATA(ACDCSCS(ACDY,1100,ACDY2))

                   QUIT 

               SET DIR(0)="9002172.71111,.01"

               SET DIR("B")=$ORDER(ACDCSCS(ACDY,1100,ACDY2,""))

               KILL DA

               DO ^DIR

               KILL DIR

               Begin DoDot:1

 +12               IF $EXTRACT(X)="@"

                       KILL ACDCSCS(ACDY,1100,ACDY2)

                       QUIT 

 +13               IF +Y'=ACDCSCS(ACDY,1100,ACDY2)

                       KILL ACDCSCS(ACDY,1100,ACDY2)

                       SET ACDCSCS(ACDY,1100,ACDY2)=+Y

                       SET ACDCSCS(ACDY,1100,ACDY2,Y(0,0))=""

 +14               QUIT 

               End DoDot:1

 +15       FOR ACDY2=ACDY2:1

               Begin DoDot:1

 +16               SET DIR(0)="9002172.71111,.01"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +17               IF '+Y

                       QUIT 

 +18               SET ACDCSCS(ACDY,1100,ACDY2)=+Y

                   SET ACDCSCS(ACDY,1100,ACDY2,Y(0,0))=""

 +19               QUIT 

               End DoDot:1

               IF 'Y

                   QUIT 

 +20       WRITE !

 +21       QUIT 

 +22      ;

GENCSMGR  ; GENERATE CS RECORDS FOR COPY SET

 +1        SET ACDCSP=$PIECE(^DD(9002172,100,0),U,2)

 +2        SET DIR(0)="9002172,.01"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF +Y<1!(+Y>31)

               SET ACDQ=1

               QUIT 

 +4        SET ACDCSDAY=+Y

 +5        WRITE !

 +6        FOR ACDY=.99:0

               SET ACDY=$ORDER(ACDCSCS(ACDY))

               IF 'ACDY

                   QUIT 

               Begin DoDot:1

 +7                SET X=$ORDER(ACDCSCS(ACDY,.01,""))

                   WRITE "Adding CS ",X,!

 +8                SET DIC="^ACDCS("

                   SET DIC(0)="L"

                   SET DLAYGO=9002172

                   SET X=ACDCSDAY

 +9                SET DIC("DR")="1////"_ACDCSCS(ACDY,.01)_";2////"_ACDCSCS(.03)_";3////"_ACDCSCS(ACDY,.02)_";7////"_DUZ_";99.99////"_ACDVIEN

 +10               DO FILE^ACDFMC

 +11               IF Y<0

                       WRITE !,IORVON,"Creation of CDMIS CLIENT SVCS record failed.  Notify programmer.",IORVOFF,!!

                       SET ACDQ=1

                       IF $DATA(^%ZOSF("$ZE"))

                           SET X="CDMIS CLIENT SVCS"

                           SET @^("$ZE")

                       DO @^%ZOSF("ERRTN")

                       DO PAUSE^ACDDEU

                       QUIT 

 +12               SET ACDCS(+Y)=""

 +13               SET ACDCSIEN=+Y

 +14               FOR ACDY2=0:0

                       SET ACDY2=$ORDER(ACDCSCS(ACDY,1100,ACDY2))

                       IF 'ACDY2

                           QUIT 

                       Begin DoDot:2

 +15                       SET DIC="^ACDCS("_ACDCSIEN_",1,"

                           SET DIC(0)="L"

                           SET DIC("P")=ACDCSP

                           SET DA(1)=ACDY

 +16                       SET X=ACDCSCS(ACDY,1100,ACDY2)

 +17                       DO FILE^ACDFMC

 +18                       IF Y<0

                               WRITE !,IORVON,"Addition of provider to CLIENT SVCS record failed.  Notify programmer.",IORVOFF,!!

                               SET ACDQ=1

                               IF $DATA(^%ZOSF("$ZE"))

                                   SET X="CDMIS CLIENT SVCS PROVIDER"

                                   SET @^("$ZE")

                               DO @^%ZOSF("ERRTN")

                               DO PAUSE^ACDDEU

                               QUIT 

 +19                       QUIT 

                       End DoDot:2

                       IF ACDQ

                           QUIT 

 +20               QUIT 

               End DoDot:1

               IF ACDQ

                   QUIT 

 +21       KILL ACDCSDAY,ACDCSIEN,ACDCSP

 +22       QUIT