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=""""""
Q
;
PRHDR ;EP PRINT HEADER
D HDR
Q
;
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
Q
;
;----------
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")
