AMHPDSM ; 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^AMHPDSM",XBRC="",XBRX="XIT^AMHPDSM",XBNS="AMH"
D ^XBDBQUE
D XIT
Q
XIT ;EP
D EN^XBVK("AMH")
Q
;
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^AMHPDSM"")"
S XBNS="AMH",XBRC="",XBRX="XIT^AMHPDSM",XBIOP=0 D ^XBDBQUE
Q
INFORM ;
W:$D(IOF) @IOF
W !,"****** PRINT/LIST PROBLEM/DSM CODE TABLE ******",!
W !,"This report will print either to a printer or the screen, a list of all"
W !,"active Problem/DSM codes. It will list the code, narrative, the 2 digit"
W !,"problem code it is mapped to and the ICD9-Diagnosis code it is"
W !,"mapped to."
Q
;
PRINT ;EP
S AMHPG=0 D HEAD
K AMHQUIT
S AMHX="" F S AMHX=$O(^AMHPROB("D",AMHX)) Q:AMHX=""!($D(AMHQUIT)) D
.S AMHY=0 F S AMHY=$O(^AMHPROB("D",AMHX,AMHY)) Q:AMHY'=+AMHY!($D(AMHQUIT)) D
..Q:$P(^AMHPROB(AMHY,0),U,13)
..Q:$P(^AMHPROB(AMHY,0),U,14)
..I $Y>(IOSL-4) D HEAD Q:$D(AMHQUIT)
..K ^UTILITY($J,"W") S X=$P(^AMHPROB(AMHY,0),U,2),DIWL=0,DIWR=52 D ^DIWP
..W !,$P(^AMHPROB(AMHY,0),U,1),?9,$G(^UTILITY($J,"W",0,1,0)),?65,$E($$VAL^XBDIQ1(9002012.2,AMHY,.03),1,12),?73,$$VAL^XBDIQ1(9002012.2,AMHY,.05)
..I $O(^UTILITY($J,"W",0,1)) D
...S X=1 S X=$O(^UTILITY($J,"W",0,X)) Q:X'=+X W !?9,^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/DSM CODES **********",80),!
W !,"CODE",?9,"NARRATIVE",?65,"PROBLEM",?73,"ICD-9",!,?65,"CODE",?73,"CODE"
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")
;----------
AMHPDSM ; 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^AMHPDSM"
SET XBRC=""
SET XBRX="XIT^AMHPDSM"
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^AMHPDSM"")"
+2 SET XBNS="AMH"
SET XBRC=""
SET XBRX="XIT^AMHPDSM"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
INFORM ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,"****** PRINT/LIST PROBLEM/DSM CODE TABLE ******",!
+3 WRITE !,"This report will print either to a printer or the screen, a list of all"
+4 WRITE !,"active Problem/DSM codes. It will list the code, narrative, the 2 digit"
+5 WRITE !,"problem code it is mapped to and the ICD9-Diagnosis code it is"
+6 WRITE !,"mapped to."
+7 QUIT
+8 ;
PRINT ;EP
+1 SET AMHPG=0
DO HEAD
+2 KILL AMHQUIT
+3 SET AMHX=""
FOR
SET AMHX=$ORDER(^AMHPROB("D",AMHX))
IF AMHX=""!($DATA(AMHQUIT))
QUIT
Begin DoDot:1
+4 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHPROB("D",AMHX,AMHY))
IF AMHY'=+AMHY!($DATA(AMHQUIT))
QUIT
Begin DoDot:2
+5 IF $PIECE(^AMHPROB(AMHY,0),U,13)
QUIT
+6 IF $PIECE(^AMHPROB(AMHY,0),U,14)
QUIT
+7 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+8 KILL ^UTILITY($JOB,"W")
SET X=$PIECE(^AMHPROB(AMHY,0),U,2)
SET DIWL=0
SET DIWR=52
DO ^DIWP
+9 WRITE !,$PIECE(^AMHPROB(AMHY,0),U,1),?9,$GET(^UTILITY($JOB,"W",0,1,0)),?65,$EXTRACT($$VAL^XBDIQ1(9002012.2,AMHY,.03),1,12),?73,$$VAL^XBDIQ1(9002012.2,AMHY,.05)
+10 IF $ORDER(^UTILITY($JOB,"W",0,1))
Begin DoDot:3
+11 SET X=1
SET X=$ORDER(^UTILITY($JOB,"W",0,X))
IF X'=+X
QUIT
WRITE !?9,^UTILITY($JOB,"W",0,X,0)
End DoDot:3
+12 WRITE !
+13 KILL ^UTILITY($JOB,"W")
End DoDot:2
End DoDot:1
+14 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/DSM CODES **********",80),!
+4 WRITE !,"CODE",?9,"NARRATIVE",?65,"PROBLEM",?73,"ICD-9",!,?65,"CODE",?73,"CODE"
+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 ;----------
