ACDDE2 ;IHS/ADC/EDE/KML - GATHER MAINLINE INFO;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
INIT ; EP
S ACDQ=1,ACDDE=1
Q:'$D(IOF)
Q:'$G(DUZ(2))
Q:'$D(^ACDF5PI(DUZ(2),0)) ; should never happen
S ACDPGM=DUZ(2)
Q:'$D(IO)
S Y=$O(^%ZIS(1,"C",IO,0)) I Y S Y=$P($G(^%ZIS(1,Y,"SUBTYPE")),U) I Y S X=$G(^%ZIS(2,Y,5)),ACDRVON=$P(X,U,4),ACDRVOF=$P(X,U,5)
I $G(ACDRVON)="" S ACDRVON="""""",ACDRVOF=""""""
S ACDDUZZ=DUZ(2)
K ^TMP("ACD",$J),^TMP($J)
S (ACDCOMC,ACDCOMCL,ACDCOMT,ACDCOMTL)=""
D HDR^ACDDEU
D GETCOMP ; ACDQ set to 0 if all ok
Q
;
GETCOMP ; EP - GET COMPONENT
S (ACDCOMC,ACDCOMT,ACDCOMTL)=""
D GETCOMPC
Q:ACDQ
D GETCOMPT
Q
;
GETCOMPC ; EP - GET COMPONENT CODE
S ACDQ=1
S Y=$G(^DISV(DUZ,"^ACDCOMP(")) I Y,$D(^ACDCOMP(Y,0)) S DIC("B")=$P(^ACDCOMP(Y,0),U)
S DIC="^ACDCOMP(",DIC(0)="AEMQZ",DIC("A")="COMPONENT (CODE): ",DIC("S")="S %=$P(^(0),U,2) I %'=""CLO"",%'=""DIS"""
D DIC^ACDFMC
Q:Y<0
S ACDCOMC=+Y,ACDCOMCL=Y(0,0)
S ACDIO=$P(Y(0),U,3) ; set for INPUT TEMPLATEs
S ACDQ=0
Q
;
GETCOMPT ; EP - GET COMPONENT TYPE
S ACDQ=1
S Y=+$O(^ACDVIS("A"),-1)
I Y S DIR("B")=$P(^ACDVIS(Y,0),U,7)
S DIR(0)="9002172.1,5",DIR("A")="COMPONENT (TYPE)" K DA D ^DIR K DIR
Q:$D(DIRUT)
Q:Y<0
S ACDCOMT=Y,ACDCOMTL=Y(0)
S ACDQ=0
Q
;
GETPROV ; EP - GET PRIMARY PROVIDER
S ACDQ=1
I $D(^TMP("ACD",$J,"PRI PROV")) S DIC("B")=^("PRI PROV") I 1
E S Y=+$G(^DISV(DUZ,"^VA(200,")) I Y S X=$P($G(^VA(200,Y,0)),U) S:X'="" DIC("B")=X
;E S Y=+$G(^DISV(DUZ,"^DIC(6,")) I Y D PFTV^XBPFTV(6,Y,.X) S:X'="" DIC("B")=X
;S DIC="^DIC(6,",DIC(0)="AEMQ",DIC("A")="PRIMARY PROVIDER: " D DIC^ACDFMC
S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="PRIMARY PROVIDER: ",DIC("S")="I $D(^XUSEC(""PROVIDER"",+Y))" D DIC^ACDFMC
Q:Y<0
S ACDPROV=+Y
S ACDPROVN=$P(Y,U,2)
;D PFTV^XBPFTV(6,ACDPROV,.ACDPROVN)
S ^TMP("ACD",$J,"PRI PROV")=ACDPROVN
S ACDQ=0
Q
;
GETTC ; EP - GET TYPE CONTACT
S ACDQ=1
I $D(^TMP("ACD",$J,"TYPE CONTACT")) S DIR("B")=^("TYPE CONTACT") I 1
E S Y=+$O(^ACDVIS("A"),-1) I Y S DIR("B")=$P(^ACDVIS(Y,0),U,4)
K:$G(ACDNODEF) DIR("B"),ACDNODEF
S DIR(0)="9002172.1,3O",DIR("A")="TYPE CONTACT" K DA D ^DIR K DIR
Q:$D(DIRUT)
Q:Y<0
S ACDCONT=Y,ACDCONTL=Y(0)
S ^TMP("ACD",$J,"TYPE CONTACT")=ACDCONTL
S ACDQ=0
Q
;
GETVDATE ; EP - GET VISIT DATE (IF OLD LOOP UNTIL ACCEPTED OR REJECTED)
F D GETVDAT2 Q:ACDQ D Q:'ACDQ
. S X1=$E(DT,1,5)_"01",X2=$E(ACDVDTI,1,5)_"01"
. D ^%DTC
. I X>90 S DIR(0)="YO",DIR("A")="VISIT DATE over 90 days ago. Do you really want this date",DIR("B")="N" K DA D ^DIR K DIR
. Q:Y
. K ^TMP("ACD",$J,"VISIT DATE")
. S ACDQ=1
. Q
Q
;
GETVDAT2 ; EP - GET SINGLE VISIT DATE
S ACDQ=1
;I $D(^TMP("ACD",$J,"VISIT DATE")) S X=^("VISIT DATE") I $E(X,6,7)'="00" S Y=X D D^DIQ S X=Y,DIR("B")=X
I $D(^TMP("ACD",$J,"VISIT DATE")) S X=^("VISIT DATE") D
. I ACDCONT="CS",$E(X,6,7)'="00" Q
. I ACDCONT'="CS",$E(X,6,7)="00" Q
. S Y=X D D^DIQ S X=Y,DIR("B")=X
. Q
K:$G(ACDNODEF) DIR("B"),ACDNODEF
S DIR(0)="9002172.1,.01",DIR("A")="VISIT DATE" K DA D ^DIR K DIR
Q:$D(DIRUT)
I ACDCONT="CS",$E(Y,6,7)'="00" D
. S $E(Y,6,7)="00"
. S ACDY=Y D D^DIQ S Y(0)=Y,Y=ACDY
. W !,"CLIENT SERVICE record for month & year only. Using ",Y(0),".",!
. NEW Y D PAUSE^ACDDEU
. Q
S (ACDDOV,ACDVDTI)=Y,ACDVDTE=Y(0)
S ^TMP("ACD",$J,"VISIT DATE")=ACDVDTI
S ACDQ=0
Q
;
HELP ; EP - HELP FOR VISIT DATE
;//^DIR
Q
ACDDE2 ;IHS/ADC/EDE/KML - GATHER MAINLINE INFO;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
INIT ; EP
+1 SET ACDQ=1
SET ACDDE=1
+2 IF '$DATA(IOF)
QUIT
+3 IF '$GET(DUZ(2))
QUIT
+4 ; should never happen
IF '$DATA(^ACDF5PI(DUZ(2),0))
QUIT
+5 SET ACDPGM=DUZ(2)
+6 IF '$DATA(IO)
QUIT
+7 SET Y=$ORDER(^%ZIS(1,"C",IO,0))
IF Y
SET Y=$PIECE($GET(^%ZIS(1,Y,"SUBTYPE")),U)
IF Y
SET X=$GET(^%ZIS(2,Y,5))
SET ACDRVON=$PIECE(X,U,4)
SET ACDRVOF=$PIECE(X,U,5)
+8 IF $GET(ACDRVON)=""
SET ACDRVON=""""""
SET ACDRVOF=""""""
+9 SET ACDDUZZ=DUZ(2)
+10 KILL ^TMP("ACD",$JOB),^TMP($JOB)
+11 SET (ACDCOMC,ACDCOMCL,ACDCOMT,ACDCOMTL)=""
+12 DO HDR^ACDDEU
+13 ; ACDQ set to 0 if all ok
DO GETCOMP
+14 QUIT
+15 ;
GETCOMP ; EP - GET COMPONENT
+1 SET (ACDCOMC,ACDCOMT,ACDCOMTL)=""
+2 DO GETCOMPC
+3 IF ACDQ
QUIT
+4 DO GETCOMPT
+5 QUIT
+6 ;
GETCOMPC ; EP - GET COMPONENT CODE
+1 SET ACDQ=1
+2 SET Y=$GET(^DISV(DUZ,"^ACDCOMP("))
IF Y
IF $DATA(^ACDCOMP(Y,0))
SET DIC("B")=$PIECE(^ACDCOMP(Y,0),U)
+3 SET DIC="^ACDCOMP("
SET DIC(0)="AEMQZ"
SET DIC("A")="COMPONENT (CODE): "
SET DIC("S")="S %=$P(^(0),U,2) I %'=""CLO"",%'=""DIS"""
+4 DO DIC^ACDFMC
+5 IF Y<0
QUIT
+6 SET ACDCOMC=+Y
SET ACDCOMCL=Y(0,0)
+7 ; set for INPUT TEMPLATEs
SET ACDIO=$PIECE(Y(0),U,3)
+8 SET ACDQ=0
+9 QUIT
+10 ;
GETCOMPT ; EP - GET COMPONENT TYPE
+1 SET ACDQ=1
+2 SET Y=+$ORDER(^ACDVIS("A"),-1)
+3 IF Y
SET DIR("B")=$PIECE(^ACDVIS(Y,0),U,7)
+4 SET DIR(0)="9002172.1,5"
SET DIR("A")="COMPONENT (TYPE)"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 IF Y<0
QUIT
+7 SET ACDCOMT=Y
SET ACDCOMTL=Y(0)
+8 SET ACDQ=0
+9 QUIT
+10 ;
GETPROV ; EP - GET PRIMARY PROVIDER
+1 SET ACDQ=1
+2 IF $DATA(^TMP("ACD",$JOB,"PRI PROV"))
SET DIC("B")=^("PRI PROV")
IF 1
+3 IF '$TEST
SET Y=+$GET(^DISV(DUZ,"^VA(200,"))
IF Y
SET X=$PIECE($GET(^VA(200,Y,0)),U)
IF X'=""
SET DIC("B")=X
+4 ;E S Y=+$G(^DISV(DUZ,"^DIC(6,")) I Y D PFTV^XBPFTV(6,Y,.X) S:X'="" DIC("B")=X
+5 ;S DIC="^DIC(6,",DIC(0)="AEMQ",DIC("A")="PRIMARY PROVIDER: " D DIC^ACDFMC
+6 SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("A")="PRIMARY PROVIDER: "
SET DIC("S")="I $D(^XUSEC(""PROVIDER"",+Y))"
DO DIC^ACDFMC
+7 IF Y<0
QUIT
+8 SET ACDPROV=+Y
+9 SET ACDPROVN=$PIECE(Y,U,2)
+10 ;D PFTV^XBPFTV(6,ACDPROV,.ACDPROVN)
+11 SET ^TMP("ACD",$JOB,"PRI PROV")=ACDPROVN
+12 SET ACDQ=0
+13 QUIT
+14 ;
GETTC ; EP - GET TYPE CONTACT
+1 SET ACDQ=1
+2 IF $DATA(^TMP("ACD",$JOB,"TYPE CONTACT"))
SET DIR("B")=^("TYPE CONTACT")
IF 1
+3 IF '$TEST
SET Y=+$ORDER(^ACDVIS("A"),-1)
IF Y
SET DIR("B")=$PIECE(^ACDVIS(Y,0),U,4)
+4 IF $GET(ACDNODEF)
KILL DIR("B"),ACDNODEF
+5 SET DIR(0)="9002172.1,3O"
SET DIR("A")="TYPE CONTACT"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
QUIT
+7 IF Y<0
QUIT
+8 SET ACDCONT=Y
SET ACDCONTL=Y(0)
+9 SET ^TMP("ACD",$JOB,"TYPE CONTACT")=ACDCONTL
+10 SET ACDQ=0
+11 QUIT
+12 ;
GETVDATE ; EP - GET VISIT DATE (IF OLD LOOP UNTIL ACCEPTED OR REJECTED)
+1 FOR
DO GETVDAT2
IF ACDQ
QUIT
Begin DoDot:1
+2 SET X1=$EXTRACT(DT,1,5)_"01"
SET X2=$EXTRACT(ACDVDTI,1,5)_"01"
+3 DO ^%DTC
+4 IF X>90
SET DIR(0)="YO"
SET DIR("A")="VISIT DATE over 90 days ago. Do you really want this date"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+5 IF Y
QUIT
+6 KILL ^TMP("ACD",$JOB,"VISIT DATE")
+7 SET ACDQ=1
+8 QUIT
End DoDot:1
IF 'ACDQ
QUIT
+9 QUIT
+10 ;
GETVDAT2 ; EP - GET SINGLE VISIT DATE
+1 SET ACDQ=1
+2 ;I $D(^TMP("ACD",$J,"VISIT DATE")) S X=^("VISIT DATE") I $E(X,6,7)'="00" S Y=X D D^DIQ S X=Y,DIR("B")=X
+3 IF $DATA(^TMP("ACD",$JOB,"VISIT DATE"))
SET X=^("VISIT DATE")
Begin DoDot:1
+4 IF ACDCONT="CS"
IF $EXTRACT(X,6,7)'="00"
QUIT
+5 IF ACDCONT'="CS"
IF $EXTRACT(X,6,7)="00"
QUIT
+6 SET Y=X
DO D^DIQ
SET X=Y
SET DIR("B")=X
+7 QUIT
End DoDot:1
+8 IF $GET(ACDNODEF)
KILL DIR("B"),ACDNODEF
+9 SET DIR(0)="9002172.1,.01"
SET DIR("A")="VISIT DATE"
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
QUIT
+11 IF ACDCONT="CS"
IF $EXTRACT(Y,6,7)'="00"
Begin DoDot:1
+12 SET $EXTRACT(Y,6,7)="00"
+13 SET ACDY=Y
DO D^DIQ
SET Y(0)=Y
SET Y=ACDY
+14 WRITE !,"CLIENT SERVICE record for month & year only. Using ",Y(0),".",!
+15 NEW Y
DO PAUSE^ACDDEU
+16 QUIT
End DoDot:1
+17 SET (ACDDOV,ACDVDTI)=Y
SET ACDVDTE=Y(0)
+18 SET ^TMP("ACD",$JOB,"VISIT DATE")=ACDVDTI
+19 SET ACDQ=0
+20 QUIT
+21 ;
HELP ; EP - HELP FOR VISIT DATE
+1 ;//^DIR
+2 QUIT
