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
