ACDPCCLS ;IHS/ADC/EDE/KML - GEN PCC LINK/HC;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
; This routine generates a PCC link or prints a hardcopy from a
; patient's CDMIS visit.
;
START ;
NEW ACDFHCP,ACDFPCC
D INIT
I ACDQ D EOJ Q
D MAIN
Q
;
INIT ;
D:'$D(ACD6DIG) ^ACD
S ACDQ=1
S DIR(0)="SO^1:PCC LINK;2:HARDCOPY",DIR("A")="Generate PCC link or hardcopy",DIR("B")="2" K DA D ^DIR K DIR
Q:$D(DIRUT)
S ACDOPT=Y
S (ACDFHCP,ACDFPCC)=0
S:ACDOPT=1 ACDFPCC=1
S:ACDOPT=2 ACDFHCP=1
I ACDFPCC S X=1 D ^ACDPCCLC I '$D(X) H 3 Q
S ACDMODE="A" ; ***** ADD, EDIT, or DELETE *****
S ACDQ=0
Q
;
HCP ; EP-GENERATE HARDCOPY FOR SELECTED PATIENTS/VISITS
;//option file
NEW ACDFHCP,ACDFPCC
S ACDFPCC=0
S ACDFHCP=1,ACDMODE="A",ACDQ=0
D MAIN
Q
;
MAIN ;
F D PATLOOP Q:ACDQ
D EOJ
Q
;
PATLOOP ; DISPLAY PATIENTS UNTIL DONE
D GETPAT
Q:ACDQ
D GETVSITS^ACDDEU ; gather all visits for patient
Q:ACDQ
D SELECT ; select visit to display
Q:ACDQ
D GENOUTP ; print hardcopy or gen pcc link
Q
;
GETPAT ; GET PATIENT
S ACDQ=1
S AUPNLK("ALL")=1
S DIC="^AUPNPAT(",DIC(0)="AEMQ",DIC("S")="I $D(^ACDVIS(""D"",Y))" D DIC^ACDFMC
K AUPNLK("ALL")
Q:Y<0
S ACDDFNP=+Y,ACDDFN=$P(^DPT(ACDDFNP,0),U)
S ACDQ=0
Q
;
SELECT ; SELECT A CDMIS VISIT
S ACDQ=1
W !
S ACDVIEN=0
K ACDVLST
I $O(^TMP("ACD",$J,"VISITS",0))="" W !,"----------",!,"No CDMIS visits!",!,"----------",! Q
S ACDDTLOW=0,ACDDTHI=9999999
I ACDVCNT>20 D GETDTRNG Q:ACDQ W !
S ACDQ=1
W !
S ACDLC=0
S ACDX=ACDDTLOW S:ACDX>0 ACDX=ACDX-1
F S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX)) Q:ACDX="" I ACDX'<ACDDTLOW,ACDX'>ACDDTHI S ACDY=0 F S ACDY=$O(^TMP("ACD",$J,"VISITS",ACDX,ACDY)) Q:'ACDY D Q:ACDQ
. S ACDQ=0
. S ACDLC=ACDLC+1
. S ACDVLST(ACDLC)=ACDY
. S DIC="9002172.1",DA=ACDY,DR=".01;1;3;5",DIQ="ACDPDD("
. D DIQ1^ACDFMC
. W ACDLC,?5,ACDPDD(9002172.1,ACDY,.01),?18," - ",ACDPDD(9002172.1,ACDY,1),"/",ACDPDD(9002172.1,ACDY,5)," ",ACDPDD(9002172.1,ACDY,3),!
. K ACDPDD
. I '(ACDLC#20) D PAUSE^ACDDEU S:$D(DIRUT) ACDQ=1
. Q
S ACDQ=1
I 'ACDLC W !,"No visits in date range",! Q
S DIR(0)="NO^1:"_ACDLC,DIR("A")="Select one of the listed visits" K DA D ^DIR K DIR
S:Y ACDVIEN=ACDVLST(Y)
K ACDLC,ACDVLST
Q:'ACDVIEN
S ACDQ=0
Q
;
GETDTRNG ; GET DATE RANGE FOR VISIT
S ACDQ=1
S ACDDTLOW=$O(^TMP("ACD",$J,"VISITS",0)),ACDDTHI=$O(^TMP("ACD",$J,"VISITS","Z"),-1)
W !,"Patient has ",ACDVCNT," visits between ",$$FMTE^XLFDT(ACDDTLOW,"1")," and ",$$FMTE^XLFDT(ACDDTHI,"1"),".",!,"Enter date range of desired visit.",!
S DIR(0)="DO^::E",DIR("A")="Enter beginning date" K DA D ^DIR K DIR
Q:'Y
S ACDDTLOW=Y
S DIR(0)="D^"_Y_"::E",DIR("A")="Enter ending date",DIR("B")=X K DA D ^DIR K DIR
Q:$D(DIRUT)
S ACDDTHI=Y
S ACDQ=0
Q
;
GENOUTP ; EP - PRINT HARDCOPY OR GENERATE PCC LINK FOR CDMIS VISIT
I ACDFPCC,$O(^ACDVIS(ACDVIEN,21,0)) W !!,"This visit already has an associated PCC visit!",! Q
S X=$P(^ACDVIS(ACDVIEN,0),U,4)
I X'="IN",X'="RE",X'="FU",X'="IR",X'="OT",X'="TD",X'="CS" W !,"INVALID TYPE CONTACT",!
E S ACDCONT=X D @("SET"_ACDCONT)
I 'ACDQ S ACDPCCLS=1 D VISIT^ACDPCCL K ACDPCCLS
Q
;
SETIN ; INITIAL
D SETIIF
Q
;
SETRE ; REOPEN
D SETIIF
Q
;
SETFU ; FOLLOWUP
D SETIIF
Q
;
SETIIF ; HARDCOPY FROM IIF ENTRY
S ACDQ=1
K ACDPCCL
S Y=$O(^ACDIIF("C",ACDVIEN,0))
Q:'Y
S ACDPCCL(ACDDFNP,ACDVIEN,"IIF",Y)=""
S ACDPCCL(ACDDFNP,ACDVIEN)=""
S ACDQ=0
Q
;
SETTD ; HARDCOPY FROM TDC ENTRY
S ACDQ=1
K ACDPCCL
S Y=$O(^ACDTDC("C",ACDVIEN,0))
Q:'Y
S ACDPCCL(ACDDFNP,ACDVIEN,"TDC",Y)=""
S ACDPCCL(ACDDFNP,ACDVIEN)=""
S ACDQ=0
Q
;
SETCS ; HARDCOPY OR PCC LINK FROM CLIENT SERVICES
S ACDY=0
F S ACDY=$O(^ACDCS("C",ACDVIEN,ACDY)) Q:'ACDY D
. S ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDY)=""
. Q
Q
;
EOJ ;
K ACDEV,ACDPCCL
D ^ACDKILL
Q
ACDPCCLS ;IHS/ADC/EDE/KML - GEN PCC LINK/HC;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
+3 ; This routine generates a PCC link or prints a hardcopy from a
+4 ; patient's CDMIS visit.
+5 ;
START ;
+1 NEW ACDFHCP,ACDFPCC
+2 DO INIT
+3 IF ACDQ
DO EOJ
QUIT
+4 DO MAIN
+5 QUIT
+6 ;
INIT ;
+1 IF '$DATA(ACD6DIG)
DO ^ACD
+2 SET ACDQ=1
+3 SET DIR(0)="SO^1:PCC LINK;2:HARDCOPY"
SET DIR("A")="Generate PCC link or hardcopy"
SET DIR("B")="2"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 SET ACDOPT=Y
+6 SET (ACDFHCP,ACDFPCC)=0
+7 IF ACDOPT=1
SET ACDFPCC=1
+8 IF ACDOPT=2
SET ACDFHCP=1
+9 IF ACDFPCC
SET X=1
DO ^ACDPCCLC
IF '$DATA(X)
HANG 3
QUIT
+10 ; ***** ADD, EDIT, or DELETE *****
SET ACDMODE="A"
+11 SET ACDQ=0
+12 QUIT
+13 ;
HCP ; EP-GENERATE HARDCOPY FOR SELECTED PATIENTS/VISITS
+1 ;//option file
+2 NEW ACDFHCP,ACDFPCC
+3 SET ACDFPCC=0
+4 SET ACDFHCP=1
SET ACDMODE="A"
SET ACDQ=0
+5 DO MAIN
+6 QUIT
+7 ;
MAIN ;
+1 FOR
DO PATLOOP
IF ACDQ
QUIT
+2 DO EOJ
+3 QUIT
+4 ;
PATLOOP ; DISPLAY PATIENTS UNTIL DONE
+1 DO GETPAT
+2 IF ACDQ
QUIT
+3 ; gather all visits for patient
DO GETVSITS^ACDDEU
+4 IF ACDQ
QUIT
+5 ; select visit to display
DO SELECT
+6 IF ACDQ
QUIT
+7 ; print hardcopy or gen pcc link
DO GENOUTP
+8 QUIT
+9 ;
GETPAT ; GET PATIENT
+1 SET ACDQ=1
+2 SET AUPNLK("ALL")=1
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^ACDVIS(""D"",Y))"
DO DIC^ACDFMC
+4 KILL AUPNLK("ALL")
+5 IF Y<0
QUIT
+6 SET ACDDFNP=+Y
SET ACDDFN=$PIECE(^DPT(ACDDFNP,0),U)
+7 SET ACDQ=0
+8 QUIT
+9 ;
SELECT ; SELECT A CDMIS VISIT
+1 SET ACDQ=1
+2 WRITE !
+3 SET ACDVIEN=0
+4 KILL ACDVLST
+5 IF $ORDER(^TMP("ACD",$JOB,"VISITS",0))=""
WRITE !,"----------",!,"No CDMIS visits!",!,"----------",!
QUIT
+6 SET ACDDTLOW=0
SET ACDDTHI=9999999
+7 IF ACDVCNT>20
DO GETDTRNG
IF ACDQ
QUIT
WRITE !
+8 SET ACDQ=1
+9 WRITE !
+10 SET ACDLC=0
+11 SET ACDX=ACDDTLOW
IF ACDX>0
SET ACDX=ACDX-1
+12 FOR
SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX))
IF ACDX=""
QUIT
IF ACDX'<ACDDTLOW
IF ACDX'>ACDDTHI
SET ACDY=0
FOR
SET ACDY=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,ACDY))
IF 'ACDY
QUIT
Begin DoDot:1
+13 SET ACDQ=0
+14 SET ACDLC=ACDLC+1
+15 SET ACDVLST(ACDLC)=ACDY
+16 SET DIC="9002172.1"
SET DA=ACDY
SET DR=".01;1;3;5"
SET DIQ="ACDPDD("
+17 DO DIQ1^ACDFMC
+18 WRITE ACDLC,?5,ACDPDD(9002172.1,ACDY,.01),?18," - ",ACDPDD(9002172.1,ACDY,1),"/",ACDPDD(9002172.1,ACDY,5)," ",ACDPDD(9002172.1,ACDY,3),!
+19 KILL ACDPDD
+20 IF '(ACDLC#20)
DO PAUSE^ACDDEU
IF $DATA(DIRUT)
SET ACDQ=1
+21 QUIT
End DoDot:1
IF ACDQ
QUIT
+22 SET ACDQ=1
+23 IF 'ACDLC
WRITE !,"No visits in date range",!
QUIT
+24 SET DIR(0)="NO^1:"_ACDLC
SET DIR("A")="Select one of the listed visits"
KILL DA
DO ^DIR
KILL DIR
+25 IF Y
SET ACDVIEN=ACDVLST(Y)
+26 KILL ACDLC,ACDVLST
+27 IF 'ACDVIEN
QUIT
+28 SET ACDQ=0
+29 QUIT
+30 ;
GETDTRNG ; GET DATE RANGE FOR VISIT
+1 SET ACDQ=1
+2 SET ACDDTLOW=$ORDER(^TMP("ACD",$JOB,"VISITS",0))
SET ACDDTHI=$ORDER(^TMP("ACD",$JOB,"VISITS","Z"),-1)
+3 WRITE !,"Patient has ",ACDVCNT," visits between ",$$FMTE^XLFDT(ACDDTLOW,"1")," and ",$$FMTE^XLFDT(ACDDTHI,"1"),".",!,"Enter date range of desired visit.",!
+4 SET DIR(0)="DO^::E"
SET DIR("A")="Enter beginning date"
KILL DA
DO ^DIR
KILL DIR
+5 IF 'Y
QUIT
+6 SET ACDDTLOW=Y
+7 SET DIR(0)="D^"_Y_"::E"
SET DIR("A")="Enter ending date"
SET DIR("B")=X
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
QUIT
+9 SET ACDDTHI=Y
+10 SET ACDQ=0
+11 QUIT
+12 ;
GENOUTP ; EP - PRINT HARDCOPY OR GENERATE PCC LINK FOR CDMIS VISIT
+1 IF ACDFPCC
IF $ORDER(^ACDVIS(ACDVIEN,21,0))
WRITE !!,"This visit already has an associated PCC visit!",!
QUIT
+2 SET X=$PIECE(^ACDVIS(ACDVIEN,0),U,4)
+3 IF X'="IN"
IF X'="RE"
IF X'="FU"
IF X'="IR"
IF X'="OT"
IF X'="TD"
IF X'="CS"
WRITE !,"INVALID TYPE CONTACT",!
+4 IF '$TEST
SET ACDCONT=X
DO @("SET"_ACDCONT)
+5 IF 'ACDQ
SET ACDPCCLS=1
DO VISIT^ACDPCCL
KILL ACDPCCLS
+6 QUIT
+7 ;
SETIN ; INITIAL
+1 DO SETIIF
+2 QUIT
+3 ;
SETRE ; REOPEN
+1 DO SETIIF
+2 QUIT
+3 ;
SETFU ; FOLLOWUP
+1 DO SETIIF
+2 QUIT
+3 ;
SETIIF ; HARDCOPY FROM IIF ENTRY
+1 SET ACDQ=1
+2 KILL ACDPCCL
+3 SET Y=$ORDER(^ACDIIF("C",ACDVIEN,0))
+4 IF 'Y
QUIT
+5 SET ACDPCCL(ACDDFNP,ACDVIEN,"IIF",Y)=""
+6 SET ACDPCCL(ACDDFNP,ACDVIEN)=""
+7 SET ACDQ=0
+8 QUIT
+9 ;
SETTD ; HARDCOPY FROM TDC ENTRY
+1 SET ACDQ=1
+2 KILL ACDPCCL
+3 SET Y=$ORDER(^ACDTDC("C",ACDVIEN,0))
+4 IF 'Y
QUIT
+5 SET ACDPCCL(ACDDFNP,ACDVIEN,"TDC",Y)=""
+6 SET ACDPCCL(ACDDFNP,ACDVIEN)=""
+7 SET ACDQ=0
+8 QUIT
+9 ;
SETCS ; HARDCOPY OR PCC LINK FROM CLIENT SERVICES
+1 SET ACDY=0
+2 FOR
SET ACDY=$ORDER(^ACDCS("C",ACDVIEN,ACDY))
IF 'ACDY
QUIT
Begin DoDot:1
+3 SET ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDY)=""
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
EOJ ;
+1 KILL ACDEV,ACDPCCL
+2 DO ^ACDKILL
+3 QUIT
