Routine: ACD

ACD ;IHS/ADC/EDE/KML - SET UP CDMIS PACKAGE VARS;

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

 ;****** Send this routine with each new patch with **n** in piece

 ;****** 3 so the patch level can be displayed as part of the

 ;****** menu header.

 ;//[ALL CDMIS OPTIONS CALL I '$D(ACD6DIG)]

START ;

 I $G(XQY0)'="",$G(ACDTOP)="" S ACDTOP=XQY0

 S ACDY="",ACDY=$O(^DIC(9.4,"C","ACD",ACDY))

 S ACDVER=^DIC(9.4,ACDY,"VERSION"),ACDVER="V"_ACDVER K ACDY

 S X=$T(+2),X=$P(X,";;",2),X=$P(X,";",3),X=$P(X,"**",2),X=$P(X,",",$L(X,","))

 S:X]"" ACDVER=ACDVER_"P"_X

 S ACDPNM="CHEMICAL DEPENDENCY MIS"

 I '$D(DUZ(2)) W !!,"Your SITE NAME is not set for the KERNEL.",!,"Please contact your System Support person.",!! S ACDQUIT=1 Q

 I $G(DUZ(0))'["M",$G(DUZ(0))'["@" W !!,"You do not have the appropriate FileMan access.",!,"Please contact your System Support person.",!! S ACDQUIT=1 Q

 I '$D(^ACDF5PI(DUZ(2),0)) W !!,"Your Program is not defined in the CDMIS PROGRAM file.",!,"Please contact your Site Manager." S ACDQUIT=1 Q

 S ACDPGM=DUZ(2)

 S ACDSITE=$P(^DIC(4,DUZ(2),0),"^"),ACD6DIG=$P(^AUTTLOC(DUZ(2),0),U,10)

 S X=$G(^ACDF5PI(ACDPGM,11)),Y=$P(X,U,3),X=$P(X,U)

 S ACDFPCC=X ;                    PCC link flag

 S ACDFHCP=Y ;                    Hardcopy bill flag

 S ACDFHCPT=0

 I $O(^ACDF5PI(ACDPGM,21,0)) F Y=0:0 S Y=$O(^ACDF5PI(ACDPGM,21,Y)) Q:'Y  S ACDFHCPT(Y)="",ACDFHCPT=ACDFHCPT+1

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

 I $G(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=""""""

PRHDR ;EP PRINT HEADER

 D HDR

HDR ;EP - Screen header.

 Q:$G(XQY0)=""

 Q:$G(ACD6DIG)=""

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

 S X=$P(XQY0,U,2),ACDMT=$S(X="ACDMENU":"Main Menu",1:X)

 S ACDPNV=ACDPNM_" "_ACDVER

 S ACDHQAF=$S($E(ACD6DIG)=9:"HEADQUARTERS",$E(ACD6DIG,3,4)="00":"AREA OFFICE",1:"")

 NEW A,D,F,I,L,N,R,V

 S F=0

 S A=$X W IORVON,IORVOFF S D=$X S:D>A F=D-A ;compute length of revvideo

 S L=18,R=61,D=R-L+1,N=R-L-1

 W @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),!

 W ?L,"*",$$CTR(ACDPNV,N),?R,"*",!

 W:ACDHQAF'="" ?L,"*",$$CTR(ACDHQAF,N),?R,"*",!

 W ?L,"*",$$CTR($$LOC(),N),?R,"*",!

 W ?L,"*",?(L+(((R-L)-$L(ACDMT))\2)),IORVON,ACDMT,IORVOFF,?R+F,"*",!

 W $$CTR($$REPEAT^XLFSTR("*",D)),!

 K ACDHQAF,ACDMT,ACDPNV

 ;----------

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

LJRF(X,Y,Z) ;EP - left justify X in a field Y wide, right filling with Z.

 NEW L,M

 I $L(X)'<Y Q $E(X,1,Y-1)_Z

 S L=Y-$L(X)

 S $P(M,Z,L)=Z

 Q X_M

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

ACD       ;IHS/ADC/EDE/KML - SET UP CDMIS PACKAGE VARS;

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

 +2       ;

 +3       ;****** Send this routine with each new patch with **n** in piece

 +4       ;****** 3 so the patch level can be displayed as part of the

 +5       ;****** menu header.

 +6       ;

 +7       ;//[ALL CDMIS OPTIONS CALL I '$D(ACD6DIG)]

START     ;

 +1        IF $GET(XQY0)'=""

               IF $GET(ACDTOP)=""

                   SET ACDTOP=XQY0

 +2        SET ACDY=""

           SET ACDY=$ORDER(^DIC(9.4,"C","ACD",ACDY))

 +3        SET ACDVER=^DIC(9.4,ACDY,"VERSION")

           SET ACDVER="V"_ACDVER

           KILL ACDY

 +4        SET X=$TEXT(+2)

           SET X=$PIECE(X,";;",2)

           SET X=$PIECE(X,";",3)

           SET X=$PIECE(X,"**",2)

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

 +5        IF X]""

               SET ACDVER=ACDVER_"P"_X

 +6        SET ACDPNM="CHEMICAL DEPENDENCY MIS"

 +7        IF '$DATA(DUZ(2))

               WRITE !!,"Your SITE NAME is not set for the KERNEL.",!,"Please contact your System Support person.",!!

               SET ACDQUIT=1

               QUIT

 +8        IF $GET(DUZ(0))'["M"

               IF $GET(DUZ(0))'["@"

                   WRITE !!,"You do not have the appropriate FileMan access.",!,"Please contact your System Support person.",!!

                   SET ACDQUIT=1

                   QUIT

 +9        IF '$DATA(^ACDF5PI(DUZ(2),0))

               WRITE !!,"Your Program is not defined in the CDMIS PROGRAM file.",!,"Please contact your Site Manager."

               SET ACDQUIT=1

               QUIT

 +10       SET ACDPGM=DUZ(2)

 +11       SET ACDSITE=$PIECE(^DIC(4,DUZ(2),0),"^")

           SET ACD6DIG=$PIECE(^AUTTLOC(DUZ(2),0),U,10)

 +12       SET X=$GET(^ACDF5PI(ACDPGM,11))

           SET Y=$PIECE(X,U,3)

           SET X=$PIECE(X,U)

 +13      ;                    PCC link flag

           SET ACDFPCC=X

 +14      ;                    Hardcopy bill flag

           SET ACDFHCP=Y

 +15       SET ACDFHCPT=0

 +16       IF $ORDER(^ACDF5PI(ACDPGM,21,0))

               FOR Y=0:0

                   SET Y=$ORDER(^ACDF5PI(ACDPGM,21,Y))

                   IF 'Y

                       QUIT

                   SET ACDFHCPT(Y)=""

                   SET ACDFHCPT=ACDFHCPT+1

 +17       IF '$DATA(IORVON)

               SET X="IORVON;IORVOFF"

               DO ENDR^%ZISS

 +18       IF $GET(IO)

               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)

 +19       IF $GET(ACDRVON)=""

               SET ACDRVON=""""""

               SET ACDRVOF=""""""

 +20       QUIT

 +21      ;

PRHDR     ;EP PRINT HEADER

 +1        DO HDR

 +2        QUIT

 +3       ;

HDR       ;EP - Screen header.

 +1        IF $GET(XQY0)=""

               QUIT

 +2        IF $GET(ACD6DIG)=""

               QUIT

 +3        IF '$DATA(IORVON)

               SET X="IORVON;IORVOFF"

               DO ENDR^%ZISS

 +4        SET X=$PIECE(XQY0,U,2)

           SET ACDMT=$SELECT(X="ACDMENU":"Main Menu",1:X)

 +5        SET ACDPNV=ACDPNM_" "_ACDVER

 +6        SET ACDHQAF=$SELECT($EXTRACT(ACD6DIG)=9:"HEADQUARTERS",$EXTRACT(ACD6DIG,3,4)="00":"AREA OFFICE",1:"")

 +7        NEW A,D,F,I,L,N,R,V

 +8        SET F=0

 +9       ;compute length of revvideo

           SET A=$X

           WRITE IORVON,IORVOFF

           SET D=$X

           IF D>A

               SET F=D-A

 +10       SET L=18

           SET R=61

           SET D=R-L+1

           SET N=R-L-1

 +11       WRITE @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),!

 +12       WRITE ?L,"*",$$CTR(ACDPNV,N),?R,"*",!

 +13       IF ACDHQAF'=""

               WRITE ?L,"*",$$CTR(ACDHQAF,N),?R,"*",!

 +14       WRITE ?L,"*",$$CTR($$LOC(),N),?R,"*",!

 +15       WRITE ?L,"*",?(L+(((R-L)-$LENGTH(ACDMT))\2)),IORVON,ACDMT,IORVOFF,?R+F,"*",!

 +16       WRITE $$CTR($$REPEAT^XLFSTR("*",D)),!

 +17       KILL ACDHQAF,ACDMT,ACDPNV

 +18       QUIT

 +19      ;

 +20      ;----------

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

LJRF(X,Y,Z) ;EP - left justify X in a field Y wide, right filling with Z.

 +1        NEW L,M

 +2        IF $LENGTH(X)'<Y

               QUIT $EXTRACT(X,1,Y-1)_Z

 +3        SET L=Y-$LENGTH(X)

 +4        SET $PIECE(M,Z,L)=Z

 +5        QUIT X_M

 +6       ;----------

USR()     ;EP - Return name of current user from ^VA(200.

 +1        QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 +2       ;----------

LOC()     ;EP - Return location name from file 4 based on DUZ(2).

 +1        QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

ACD.m