- 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 ;----------
