ACDDEU.m

ACDDEU ;IHS/ADC/EDE/KML - COMMON FUNCTIONS; 

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

 ;

DEV ; EP - SELECT OUTPUT DEVICE

 K ACDSLAVE

 S ACDQ=0

 S %ZIS="Q",%ZIS("B")="" D ^%ZIS

 I POP S ACDQ=1

 I $D(IO("S")) S ACDSLAVE=ION W @IOF D ^%ZISC

 Q

 ;

PAUSE ; EP - PAUSE FOR USER

 Q:$E(IOST)'="C"

 Q:$D(ZTQUEUED)!'(IOT["TRM")!$D(IO("S"))   ;*** TESTING - AEF *** CHANGED ="TRM" TO ["TRM" TO ACCOUNT FOR "VTRM"

 S DIR(0)="E",DIR("A")="Press any key to continue"

 K DIRUT

 D ^DIR K DIR

 Q

 ;

CONF ; EP - CONFIDENTIAL CLIENT DATA HEADER

 W !,"*** CONFIDENTIAL CLIENT INFORMATION UNDER CFR 42 PART 2 ***",!

 NEW X,Y

 D NOW^%DTC S Y=$$DD^ACDFUNC(%) W !,"PRINTED: "_Y_" BY: "_$P($G(^VA(200,DUZ,0)),U)_"@"_ACDSITE,!

 S X="",$P(X,"=",79)="" W X,!

 Q

 ;

HDR ; EP - DISPLAY HEADER

 D HDR2

 S X="",$P(X,"-",79)=""

 W X,!

 K X

 Q

 ;

HDR2 ;

 W @IOF,"Signon Program is            : ",$P(^DIC(4,DUZ(2),0),U),!

 I ACDMODE="A" D

 . W "Records that may be added are: THOSE WITHIN YOUR SIGNIN PROGRAM.",!!

 . W "ADDING CDMIS VISIT RECORDS...",!!

 . Q

 I ACDMODE="E" D

 . W "Editable Records are: THOSE NOT EXTRACTED.",!

 . W "                      THOSE WITHIN YOUR SIGNIN PROGRAM.",!!

 . W "EDITING CDMIS VISIT RECORDS...",!!

 . Q

 Q:$G(ACDCOMCL)=""

 W "COMPONENT (CODE)             : ",ACDCOMCL,!

 W "COMPONENT (TYPE)             : ",ACDCOMTL,!

 I ACDLPTYP=1 Q:$G(ACDPROV)=""  W !,"PRIMARY PROVIDER             : ",ACDPROVN,!

 Q:ACDCONTL=""

 W !,"TYPE CONTACT                 : ",ACDCONTL,!

 I ACDLPTYP=2,$G(ACDCSDP)'=""  W "DEFAULT PROVIDER             : ",ACDCSDP,!

 Q:ACDVDTE=""

 W "VISIT DATE                   : ",ACDVDTE,!

 Q

 ;

DSPVSIT(VISIT) ; EP - DISPLAY CDMIS VISIT ENTRY

 Q:'VISIT

 S DIC="^ACDVIS(",DA=VISIT,DR=0

 D DIQ^ACDFMC

 Q

 ;

DSPHIST ; EP - DISPLAY CDMIS VISIT HISTORY  

 I '$D(^TMP("ACD",$J,"VISITS")) D  Q

 . W !,"----------",!

 . W "No CDMIS VISIT history for client ",ACDDFN,!

 . W "----------",!

 . Q

 I $E(IOST,1,2)="P-" D FWD I 1

 E  D BCK

 Q

 ;

FWD ; FORWARD DISPLAY FOR PRINTERS ONLY

 D CONF W !

 W "CDMIS VISIT history for client ",ACDDFN,!!

 W "----------",!

 S ACDX=0

 F  S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX)) Q:ACDX=""  S ACDY=0 F  S ACDY=$O(^TMP("ACD",$J,"VISITS",ACDX,ACDY)) Q:'ACDY  D DSPV I $P(^ACDVIS(ACDY,0),U,4)="CS" S ACDVIEN=ACDY D DSPCSH

 W "----------",!

 Q

 ;

BCK ; BACKWARD DISPLAY FOR CRTS

 W !,"----------",!

 W "Recent CDMIS VISIT history for client ",ACDDFN,!!

 S ACDX="A",ACDCNT=0

 F  Q:ACDX="Q"  S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX),-1) Q:ACDX=""  S ACDY=0 F  S ACDY=$O(^TMP("ACD",$J,"VISITS",ACDX,ACDY)) Q:'ACDY  D DSPV S ACDCNT=ACDCNT+1 I ACDCNT>17 S ACDX="Q" Q

 K ACDCNT

 W "----------",!

 Q

 ;

DSPV ; EP-DISPLAY CDMIS VISIT ENTRY

 S DIC="9002172.1",DA=ACDY,DR=".01;1;3;5",DIQ="ACDPDD("

 D DIQ1^ACDFMC

 W ACDPDD(9002172.1,ACDY,.01),?12," - ",ACDPDD(9002172.1,ACDY,1),"/",ACDPDD(9002172.1,ACDY,5),?52,ACDPDD(9002172.1,ACDY,3),?70,$S($P(^ACDVIS(ACDY,0),U,25):" <EXTR>",1:""),!

 K ACDPDD

 Q

 ;

DSPCSH ; EP-DISPLAY CDMIS CLIENT SERVICE HISTORY FOR ONE CS VISIT

 K ^TMP("ACD",$J,"CS")

 S Y=0

 F  S Y=$O(^ACDCS("C",ACDVIEN,Y)) Q:'Y  S X=^ACDCS(Y,0),^TMP("ACD",$J,"CS",$P(X,U),Y)=$P(X,U,2)

 S Y=0

 F  S Y=$O(^TMP("ACD",$J,"CS",Y)) Q:'Y  S Z=0 F  S Z=$O(^TMP("ACD",$J,"CS",Y,Z)) Q:'Z  D

 .  S X=^TMP("ACD",$J,"CS",Y,Z)

 .  D PFTV^XBPFTV(9002170.6,X,.W)

 .  W ?15,Y,?19,W,?55,$J(+$P(^ACDCS(Z,0),U,4),5,2)_" h",!

 .  Q

 K ^TMP("ACD",$J,"CS")

 Q

 ;

GETVSITS ; EP - GET CDMIS VISITS FOR THIS CLIENT

 K ^TMP("ACD",$J,"VISITS")

 S ACDVCNT=0,Y=0

 F  S Y=$O(^ACDVIS("D",ACDDFNP,Y)) Q:'Y  S X=^ACDVIS(Y,0) I $P($G(^("BWP")),U)=ACDPGM D

 .  I $G(ACDTCTG)'="",$P(X,U,4)'=ACDTCTG Q  ; quit if tc not wanted

 .  S ^TMP("ACD",$J,"VISITS",$P(X,U),Y)=X,ACDVCNT=ACDVCNT+1

 .  Q

 Q

 ;

CHKFIN ; EP - CHECK FOR INITIAL CONTACT TYPE

 I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS

 S ACDX="",(ACDY,Y)=0

 F  S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX)) Q:ACDX=""  S Y=0 F  S Y=$O(^TMP("ACD",$J,"VISITS",ACDX,Y)) Q:'Y  S X=^(Y) I $P(X,U,2)=ACDCOMC,$P(X,U,7)=ACDCOMT,$P(X,U,4)="IN" S ACDY=Y Q

 I ACDY,'ACDINR W !,IORVON,"INITIAL type contact already exists for patient ",ACDDFN,!,"in the ",ACDCOMCL,"/",ACDCOMTL," component.",IORVOFF,! D DSPVSIT^ACDDEU(ACDY),PAUSE^ACDDEU S ACDQ=1 Q

 Q:ACDY  ;            quit if INITIAL type contact found

 Q:'ACDINR  ;         quit if INITIAL type contact not required.

 S ACDQ=1

 W !,IORVON,"No INITIAL type contact for patient ",ACDDFN,!,"in the ",ACDCOMCL,"/",ACDCOMTL," component.",IORVOFF,!!,"Now searching for a REOPEN.",!

 S ACDX="",(ACDY,Y)=0

 F  S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX)) Q:ACDX=""  S Y=0 F  S Y=$O(^TMP("ACD",$J,"VISITS",ACDX,Y)) Q:'Y  S X=^(Y) I $P(X,U,2)=ACDCOMC,$P(X,U,7)=ACDCOMT,$P(X,U,4)="RE" S ACDY=Y Q

 I ACDY S ACDQ=0 W !,"REOPEN found.",! Q

 W !,IORVON,"No INITIAL or REOPEN found.",IORVOFF,!

 D PAUSE^ACDDEU

 Q

 ;

GETDTR ; EP-GET DATE RANGE

 ; returns ACDDTLO and ACDDTHI or ACDQ=1

 F  D GETDTR2 Q:$D(DIRUT)  Q:'ACDQ

 K:ACDQ ACDDTLO,ACDDTHI

 Q

 ;

GETDTR2 ;

 S ACDQ=1

 S DIR(0)="DO^::EP",DIR("A")="Enter beginning date" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 Q:Y=""

 S ACDDTLO=Y

 S DIR(0)="DO^::EP",DIR("A")="Enter ending date" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 Q:Y=""

 S ACDDTHI=Y

 I ACDDTHI<ACDDTLO W !!,"Ending date before beginning date!",!! Q

 S:$E(ACDDTLO,6,7)="01" $E(ACDDTLO,6,7)="00" ;   to get CS visits

 S ACDQ=0

 Q

GETTOB ; get tobacco use info

 ; utilized by input templates ACD I/I/F ADD and ACD T/D/C/ ADD

 N DIR S DIR(0)="S^0:NONE;1:SMOKING;2:SMOKELESS;3:SMOKING & SMOKELESS",DIR("A")="TOBACCO USE" D ^DIR

 I Y N DR S DR="30///^S X=Y" D ^DIE

 Q

ACDDEU    ;IHS/ADC/EDE/KML - COMMON FUNCTIONS; 

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

 +2       ;

DEV       ; EP - SELECT OUTPUT DEVICE

 +1        KILL ACDSLAVE

 +2        SET ACDQ=0

 +3        SET %ZIS="Q"

           SET %ZIS("B")=""

           DO ^%ZIS

 +4        IF POP

               SET ACDQ=1

 +5        IF $DATA(IO("S"))

               SET ACDSLAVE=ION

               WRITE @IOF

               DO ^%ZISC

 +6        QUIT 

 +7       ;

PAUSE     ; EP - PAUSE FOR USER

 +1        IF $EXTRACT(IOST)'="C"

               QUIT 

 +2       ;*** TESTING - AEF *** CHANGED ="TRM" TO ["TRM" TO ACCOUNT FOR "VTRM"

           IF $DATA(ZTQUEUED)!'(IOT["TRM")!$DATA(IO("S"))

               QUIT 

 +3        SET DIR(0)="E"

           SET DIR("A")="Press any key to continue"

 +4        KILL DIRUT

 +5        DO ^DIR

           KILL DIR

 +6        QUIT 

 +7       ;

CONF      ; EP - CONFIDENTIAL CLIENT DATA HEADER

 +1        WRITE !,"*** CONFIDENTIAL CLIENT INFORMATION UNDER CFR 42 PART 2 ***",!

 +2        NEW X,Y

 +3        DO NOW^%DTC

           SET Y=$$DD^ACDFUNC(%)

           WRITE !,"PRINTED: "_Y_" BY: "_$PIECE($GET(^VA(200,DUZ,0)),U)_"@"_ACDSITE,!

 +4        SET X=""

           SET $PIECE(X,"=",79)=""

           WRITE X,!

 +5        QUIT 

 +6       ;

HDR       ; EP - DISPLAY HEADER

 +1        DO HDR2

 +2        SET X=""

           SET $PIECE(X,"-",79)=""

 +3        WRITE X,!

 +4        KILL X

 +5        QUIT 

 +6       ;

HDR2      ;

 +1        WRITE @IOF,"Signon Program is            : ",$PIECE(^DIC(4,DUZ(2),0),U),!

 +2        IF ACDMODE="A"

               Begin DoDot:1

 +3                WRITE "Records that may be added are: THOSE WITHIN YOUR SIGNIN PROGRAM.",!!

 +4                WRITE "ADDING CDMIS VISIT RECORDS...",!!

 +5                QUIT 

               End DoDot:1

 +6        IF ACDMODE="E"

               Begin DoDot:1

 +7                WRITE "Editable Records are: THOSE NOT EXTRACTED.",!

 +8                WRITE "                      THOSE WITHIN YOUR SIGNIN PROGRAM.",!!

 +9                WRITE "EDITING CDMIS VISIT RECORDS...",!!

 +10               QUIT 

               End DoDot:1

 +11       IF $GET(ACDCOMCL)=""

               QUIT 

 +12       WRITE "COMPONENT (CODE)             : ",ACDCOMCL,!

 +13       WRITE "COMPONENT (TYPE)             : ",ACDCOMTL,!

 +14       IF ACDLPTYP=1

               IF $GET(ACDPROV)=""

                   QUIT 

               WRITE !,"PRIMARY PROVIDER             : ",ACDPROVN,!

 +15       IF ACDCONTL=""

               QUIT 

 +16       WRITE !,"TYPE CONTACT                 : ",ACDCONTL,!

 +17       IF ACDLPTYP=2

               IF $GET(ACDCSDP)'=""

                   WRITE "DEFAULT PROVIDER             : ",ACDCSDP,!

 +18       IF ACDVDTE=""

               QUIT 

 +19       WRITE "VISIT DATE                   : ",ACDVDTE,!

 +20       QUIT 

 +21      ;

DSPVSIT(VISIT) ; EP - DISPLAY CDMIS VISIT ENTRY

 +1        IF 'VISIT

               QUIT 

 +2        SET DIC="^ACDVIS("

           SET DA=VISIT

           SET DR=0

 +3        DO DIQ^ACDFMC

 +4        QUIT 

 +5       ;

DSPHIST   ; EP - DISPLAY CDMIS VISIT HISTORY  

 +1        IF '$DATA(^TMP("ACD",$JOB,"VISITS"))

               Begin DoDot:1

 +2                WRITE !,"----------",!

 +3                WRITE "No CDMIS VISIT history for client ",ACDDFN,!

 +4                WRITE "----------",!

 +5                QUIT 

               End DoDot:1

               QUIT 

 +6        IF $EXTRACT(IOST,1,2)="P-"

               DO FWD

               IF 1

 +7       IF '$TEST

               DO BCK

 +8        QUIT 

 +9       ;

FWD       ; FORWARD DISPLAY FOR PRINTERS ONLY

 +1        DO CONF

           WRITE !

 +2        WRITE "CDMIS VISIT history for client ",ACDDFN,!!

 +3        WRITE "----------",!

 +4        SET ACDX=0

 +5        FOR 

               SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX))

               IF ACDX=""

                   QUIT 

               SET ACDY=0

               FOR 

                   SET ACDY=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,ACDY))

                   IF 'ACDY

                       QUIT 

                   DO DSPV

                   IF $PIECE(^ACDVIS(ACDY,0),U,4)="CS"

                       SET ACDVIEN=ACDY

                       DO DSPCSH

 +6        WRITE "----------",!

 +7        QUIT 

 +8       ;

BCK       ; BACKWARD DISPLAY FOR CRTS

 +1        WRITE !,"----------",!

 +2        WRITE "Recent CDMIS VISIT history for client ",ACDDFN,!!

 +3        SET ACDX="A"

           SET ACDCNT=0

 +4        FOR 

               IF ACDX="Q"

                   QUIT 

               SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX),-1)

               IF ACDX=""

                   QUIT 

               SET ACDY=0

               FOR 

                   SET ACDY=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,ACDY))

                   IF 'ACDY

                       QUIT 

                   DO DSPV

                   SET ACDCNT=ACDCNT+1

                   IF ACDCNT>17

                       SET ACDX="Q"

                       QUIT 

 +5        KILL ACDCNT

 +6        WRITE "----------",!

 +7        QUIT 

 +8       ;

DSPV      ; EP-DISPLAY CDMIS VISIT ENTRY

 +1        SET DIC="9002172.1"

           SET DA=ACDY

           SET DR=".01;1;3;5"

           SET DIQ="ACDPDD("

 +2        DO DIQ1^ACDFMC

 +3        WRITE ACDPDD(9002172.1,ACDY,.01),?12," - ",ACDPDD(9002172.1,ACDY,1),"/",ACDPDD(9002172.1,ACDY,5),?52,ACDPDD(9002172.1,ACDY,3),?70,$SELECT($PIECE(^ACDVIS(ACDY,0),U,25):" <EXTR>",1:""),!

 +4        KILL ACDPDD

 +5        QUIT 

 +6       ;

DSPCSH    ; EP-DISPLAY CDMIS CLIENT SERVICE HISTORY FOR ONE CS VISIT

 +1        KILL ^TMP("ACD",$JOB,"CS")

 +2        SET Y=0

 +3        FOR 

               SET Y=$ORDER(^ACDCS("C",ACDVIEN,Y))

               IF 'Y

                   QUIT 

               SET X=^ACDCS(Y,0)

               SET ^TMP("ACD",$JOB,"CS",$PIECE(X,U),Y)=$PIECE(X,U,2)

 +4        SET Y=0

 +5        FOR 

               SET Y=$ORDER(^TMP("ACD",$JOB,"CS",Y))

               IF 'Y

                   QUIT 

               SET Z=0

               FOR 

                   SET Z=$ORDER(^TMP("ACD",$JOB,"CS",Y,Z))

                   IF 'Z

                       QUIT 

                   Begin DoDot:1

 +6                    SET X=^TMP("ACD",$JOB,"CS",Y,Z)

 +7                    DO PFTV^XBPFTV(9002170.6,X,.W)

 +8                    WRITE ?15,Y,?19,W,?55,$JUSTIFY(+$PIECE(^ACDCS(Z,0),U,4),5,2)_" h",!

 +9                    QUIT 

                   End DoDot:1

 +10       KILL ^TMP("ACD",$JOB,"CS")

 +11       QUIT 

 +12      ;

GETVSITS  ; EP - GET CDMIS VISITS FOR THIS CLIENT

 +1        KILL ^TMP("ACD",$JOB,"VISITS")

 +2        SET ACDVCNT=0

           SET Y=0

 +3        FOR 

               SET Y=$ORDER(^ACDVIS("D",ACDDFNP,Y))

               IF 'Y

                   QUIT 

               SET X=^ACDVIS(Y,0)

               IF $PIECE($GET(^("BWP")),U)=ACDPGM

                   Begin DoDot:1

 +4       ; quit if tc not wanted

                       IF $GET(ACDTCTG)'=""

                           IF $PIECE(X,U,4)'=ACDTCTG

                               QUIT 

 +5                    SET ^TMP("ACD",$JOB,"VISITS",$PIECE(X,U),Y)=X

                       SET ACDVCNT=ACDVCNT+1

 +6                    QUIT 

                   End DoDot:1

 +7        QUIT 

 +8       ;

CHKFIN    ; EP - CHECK FOR INITIAL CONTACT TYPE

 +1        IF '$DATA(IORVON)

               SET X="IORVON;IORVOFF"

               DO ENDR^%ZISS

 +2        SET ACDX=""

           SET (ACDY,Y)=0

 +3        FOR 

               SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX))

               IF ACDX=""

                   QUIT 

               SET Y=0

               FOR 

                   SET Y=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,Y))

                   IF 'Y

                       QUIT 

                   SET X=^(Y)

                   IF $PIECE(X,U,2)=ACDCOMC

                       IF $PIECE(X,U,7)=ACDCOMT

                           IF $PIECE(X,U,4)="IN"

                               SET ACDY=Y

                               QUIT 

 +4        IF ACDY

               IF 'ACDINR

                   WRITE !,IORVON,"INITIAL type contact already exists for patient ",ACDDFN,!,"in the ",ACDCOMCL,"/",ACDCOMTL," component.",IORVOFF,!

                   DO DSPVSIT^ACDDEU(ACDY)

                   DO PAUSE^ACDDEU

                   SET ACDQ=1

                   QUIT 

 +5       ;            quit if INITIAL type contact found

           IF ACDY

               QUIT 

 +6       ;         quit if INITIAL type contact not required.

           IF 'ACDINR

               QUIT 

 +7        SET ACDQ=1

 +8        WRITE !,IORVON,"No INITIAL type contact for patient ",ACDDFN,!,"in the ",ACDCOMCL,"/",ACDCOMTL," component.",IORVOFF,!!,"Now searching for a REOPEN.",!

 +9        SET ACDX=""

           SET (ACDY,Y)=0

 +10       FOR 

               SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX))

               IF ACDX=""

                   QUIT 

               SET Y=0

               FOR 

                   SET Y=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,Y))

                   IF 'Y

                       QUIT 

                   SET X=^(Y)

                   IF $PIECE(X,U,2)=ACDCOMC

                       IF $PIECE(X,U,7)=ACDCOMT

                           IF $PIECE(X,U,4)="RE"

                               SET ACDY=Y

                               QUIT 

 +11       IF ACDY

               SET ACDQ=0

               WRITE !,"REOPEN found.",!

               QUIT 

 +12       WRITE !,IORVON,"No INITIAL or REOPEN found.",IORVOFF,!

 +13       DO PAUSE^ACDDEU

 +14       QUIT 

 +15      ;

GETDTR    ; EP-GET DATE RANGE

 +1       ; returns ACDDTLO and ACDDTHI or ACDQ=1

 +2        FOR 

               DO GETDTR2

               IF $DATA(DIRUT)

                   QUIT 

               IF 'ACDQ

                   QUIT 

 +3        IF ACDQ

               KILL ACDDTLO,ACDDTHI

 +4        QUIT 

 +5       ;

GETDTR2   ;

 +1        SET ACDQ=1

 +2        SET DIR(0)="DO^::EP"

           SET DIR("A")="Enter beginning date"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        IF Y=""

               QUIT 

 +5        SET ACDDTLO=Y

 +6        SET DIR(0)="DO^::EP"

           SET DIR("A")="Enter ending date"

           KILL DA

           DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)

               QUIT 

 +8        IF Y=""

               QUIT 

 +9        SET ACDDTHI=Y

 +10       IF ACDDTHI<ACDDTLO

               WRITE !!,"Ending date before beginning date!",!!

               QUIT 

 +11      ;   to get CS visits

           IF $EXTRACT(ACDDTLO,6,7)="01"

               SET $EXTRACT(ACDDTLO,6,7)="00"

 +12       SET ACDQ=0

 +13       QUIT 

GETTOB    ; get tobacco use info

 +1       ; utilized by input templates ACD I/I/F ADD and ACD T/D/C/ ADD

 +2        NEW DIR

           SET DIR(0)="S^0:NONE;1:SMOKING;2:SMOKELESS;3:SMOKING & SMOKELESS"

           SET DIR("A")="TOBACCO USE"

           DO ^DIR

 +3        IF Y

               NEW DR

               SET DR="30///^S X=Y"

               DO ^DIE

 +4        QUIT