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
