AMHPPC ; IHS/CMI/LAB - All visit report driver ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
START ;
D INFORM
ZIS ;CALL TO XBDBQUE
S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR
I $D(DIRUT) G XIT
I $G(Y)="B" D BROWSE,XIT Q
S XBRP="PRINT^AMHPPC",XBRC="",XBRX="XIT^AMHPPC",XBNS="AMH"
D ^XBDBQUE
D XIT
Q
XIT ;EP
D EN^XBVK("AMH")
Q
;
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^AMHPPC"")"
S XBNS="AMH",XBRC="",XBRX="XIT^AMHPPC",XBIOP=0 D ^XBDBQUE
Q
INFORM ;
W:$D(IOF) @IOF
W !,"****** PRINT/LIST PROBLEM CODE TABLE ******",!
W !,"This report will print either to a printer or the screen, a list of all"
W !,"active Problem codes. It will list the code, narrative, and the"
W !,"problem category.",!
Q
;
PRINT ;EP
S AMHPG=0 D HEAD
K AMHQUIT
S AMHX="" F S AMHX=$O(^AMHPROBC("B",AMHX)) Q:AMHX=""!($D(AMHQUIT)) D
.S AMHY=0 F S AMHY=$O(^AMHPROBC("B",AMHX,AMHY)) Q:AMHY'=+AMHY!($D(AMHQUIT)) D
..Q:$P(^AMHPROBC(AMHY,0),U,4)
..I $Y>(IOSL-4) D HEAD Q:$D(AMHQUIT)
..K ^UTILITY($J,"W") S X=$P(^AMHPROBC(AMHY,0),U,2),DIWL=0,DIWR=50 D ^DIWP
..W !,$P(^AMHPROBC(AMHY,0),U,1),?6,$G(^UTILITY($J,"W",0,1,0)),?58,$E($$VAL^XBDIQ1(9002012.4,AMHY,.03),1,20)
..I $O(^UTILITY($J,"W",0,1)) D
...S X=1 S X=$O(^UTILITY($J,"W",0,X)) Q:X'=+X W !?6,^UTILITY($J,"W",0,X,0)
..W !
..K ^UTILITY($J,"W")
Q
HEAD I 'AMHPG G HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF S AMHPG=AMHPG+1
W !,$P(^VA(200,DUZ,0),U,2),?40,$$FMTE^XLFDT(DT),?68,"Page ",AMHPG,!
W !,$$CTR("********** BEHAVIORAL HEALTH PROBLEM CODES **********",80),!
W !,"CODE",?6,"NARRATIVE",?58,"PROBLEM CATEGORY"
W !,$TR($J(" ",80)," ","-")
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:IO'=IO(0)
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
W !
S DIR("A")="End of Report. Press Enter",DIR(0)="E" D ^DIR
Q
;----------
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")
;----------
AMHPPC ; IHS/CMI/LAB - All visit report driver ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
START ;
+1 DO INFORM
ZIS ;CALL TO XBDBQUE
+1 SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"
SET DIR("A")="Do you wish to "
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
GOTO XIT
+3 IF $GET(Y)="B"
DO BROWSE
DO XIT
QUIT
+4 SET XBRP="PRINT^AMHPPC"
SET XBRC=""
SET XBRX="XIT^AMHPPC"
SET XBNS="AMH"
+5 DO ^XBDBQUE
+6 DO XIT
+7 QUIT
XIT ;EP
+1 DO EN^XBVK("AMH")
+2 QUIT
+3 ;
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^AMHPPC"")"
+2 SET XBNS="AMH"
SET XBRC=""
SET XBRX="XIT^AMHPPC"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
INFORM ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,"****** PRINT/LIST PROBLEM CODE TABLE ******",!
+3 WRITE !,"This report will print either to a printer or the screen, a list of all"
+4 WRITE !,"active Problem codes. It will list the code, narrative, and the"
+5 WRITE !,"problem category.",!
+6 QUIT
+7 ;
PRINT ;EP
+1 SET AMHPG=0
DO HEAD
+2 KILL AMHQUIT
+3 SET AMHX=""
FOR
SET AMHX=$ORDER(^AMHPROBC("B",AMHX))
IF AMHX=""!($DATA(AMHQUIT))
QUIT
Begin DoDot:1
+4 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHPROBC("B",AMHX,AMHY))
IF AMHY'=+AMHY!($DATA(AMHQUIT))
QUIT
Begin DoDot:2
+5 IF $PIECE(^AMHPROBC(AMHY,0),U,4)
QUIT
+6 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+7 KILL ^UTILITY($JOB,"W")
SET X=$PIECE(^AMHPROBC(AMHY,0),U,2)
SET DIWL=0
SET DIWR=50
DO ^DIWP
+8 WRITE !,$PIECE(^AMHPROBC(AMHY,0),U,1),?6,$GET(^UTILITY($JOB,"W",0,1,0)),?58,$EXTRACT($$VAL^XBDIQ1(9002012.4,AMHY,.03),1,20)
+9 IF $ORDER(^UTILITY($JOB,"W",0,1))
Begin DoDot:3
+10 SET X=1
SET X=$ORDER(^UTILITY($JOB,"W",0,X))
IF X'=+X
QUIT
WRITE !?6,^UTILITY($JOB,"W",0,X,0)
End DoDot:3
+11 WRITE !
+12 KILL ^UTILITY($JOB,"W")
End DoDot:2
End DoDot:1
+13 QUIT
HEAD IF 'AMHPG
GOTO HEAD1
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET AMHQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET AMHPG=AMHPG+1
+2 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?40,$$FMTE^XLFDT(DT),?68,"Page ",AMHPG,!
+3 WRITE !,$$CTR("********** BEHAVIORAL HEALTH PROBLEM CODES **********",80),!
+4 WRITE !,"CODE",?6,"NARRATIVE",?58,"PROBLEM CATEGORY"
+5 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+6 QUIT
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 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF IO'=IO(0)
QUIT
+3 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+4 NEW DIR
+5 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+6 WRITE !
+7 SET DIR("A")="End of Report. Press Enter"
SET DIR(0)="E"
DO ^DIR
+8 QUIT
+9 ;----------
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")
+2 ;----------
