- AMHRC5 ; IHS/CMI/LAB - PERSONAL HX REPORT ;
- ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
- ;
- START ;
- I '$D(IOF) D HOME^%ZIS
- W @(IOF),!!
- W "******* LIST OF PATIENTS WITH PERSONAL HISTORY ITEMS *******",!!
- D DBHUSRP^AMHUTIL
- ;
- DEMO ;
- D DEMOCHK^AMHUTIL1(.AMHDEMO)
- I AMHDEMO=-1 G XIT
- ZIS ;
- 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 XBRC="PROC^AMHRC5",XBRP="PRINT^AMHRC5",XBNS="AMH",XBRX="XIT^AMHRC5"
- D ^XBDBQUE
- XIT ;
- D EN^XBVK("AMH")
- Q
- ;
- BROWSE ;
- S XBRP="VIEWR^XBLM(""PRINT^AMHRC5"")"
- S XBNS="AMH",XBRC="PROC^AMHRC5",XBRX="XIT^AMHRC5",XBIOP=0 D ^XBDBQUE
- Q
- PROC ;EP - entry point for processing
- S AMHBT=$H K AMHDISP
- S AMHCASE=0
- F S AMHCASE=$O(^AMHPPHX(AMHCASE)) Q:AMHCASE'=+AMHCASE D PROC1
- S AMHET=$H
- K AMHCASE
- Q
- PROC1 ;
- S AMHR=^AMHPPHX(AMHCASE,0)
- Q:'$$ALLOWP^AMHUTIL(DUZ,$P(AMHR,U,2))
- Q:$$DEMO^AMHUTIL1($P(AMHR,U,2),$G(AMHDEMO))
- Q:$P(AMHR,U,1)=""
- S X=$P(AMHR,U,1)
- Q:'$D(^AMHTPHF(X))
- S X=$P(^AMHTPHF(X,0),U)
- S:'$D(AMHDISP(X)) AMHDISP(X)="" S AMHDISP(X)=AMHDISP(X)+1,AMHDISP(X,$P(^DPT($P(AMHR,U,2),0),U),$P(AMHR,U,2))=""
- Q
- PRINT ;EP - CALLED FROM XBDBQUE
- S AMH80D="-------------------------------------------------------------------------------"
- S AMHPG=0 D HEAD
- K AMHQ
- S AMHX="" F S AMHX=$O(AMHDISP(AMHX)) Q:AMHX=""!($D(AMHQ)) D
- .I $Y>(IOSL-3) D HEAD Q:$D(AMHQ)
- .W !!,?17,AMHX
- .S AMHNAME="" F S AMHNAME=$O(AMHDISP(AMHX,AMHNAME)) Q:AMHNAME=""!($D(AMHQ)) D
- ..S AMHP=0 F S AMHP=$O(AMHDISP(AMHX,AMHNAME,AMHP)) Q:AMHP'=+AMHP!($D(AMHQ)) D
- ...I $Y>(IOSL-3) D HEAD
- ...W !?10,AMHNAME,?42,$$VAL^XBDIQ1(2,AMHP,.02),?52,$$AGE^AUPNPAT(AMHP,DT),?57,$$HRN^AUPNPAT(AMHP,DUZ(2))
- .W !,"SUBCOUNT: ",AMHDISP(AMHX)
- .Q
- DONE ;
- D EOP^AMHRDE1
- 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 AMHQ="" Q
- HEAD1 ;
- W:$D(IOF) @IOF S AMHPG=AMHPG+1
- W !,$P(^VA(200,DUZ,0),U,2),?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
- W "PERSONAL HISTORY LIST BY PATIENT",?44,$$FMTE^XLFDT($$NOW^XLFDT),?72,"Page ",AMHPG,!
- W ?10,"PATIENT",?42,"SEX",?52,"AGE",?57,"CHART NUMBER",!
- W AMH80D,!
- Q
- AMHRC5 ; IHS/CMI/LAB - PERSONAL HX REPORT ;
- +1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
- +2 ;
- START ;
- +1 IF '$DATA(IOF)
- DO HOME^%ZIS
- +2 WRITE @(IOF),!!
- +3 WRITE "******* LIST OF PATIENTS WITH PERSONAL HISTORY ITEMS *******",!!
- +4 DO DBHUSRP^AMHUTIL
- +5 ;
- DEMO ;
- +1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
- +2 IF AMHDEMO=-1
- GOTO XIT
- ZIS ;
- +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 XBRC="PROC^AMHRC5"
- SET XBRP="PRINT^AMHRC5"
- SET XBNS="AMH"
- SET XBRX="XIT^AMHRC5"
- +5 DO ^XBDBQUE
- XIT ;
- +1 DO EN^XBVK("AMH")
- +2 QUIT
- +3 ;
- BROWSE ;
- +1 SET XBRP="VIEWR^XBLM(""PRINT^AMHRC5"")"
- +2 SET XBNS="AMH"
- SET XBRC="PROC^AMHRC5"
- SET XBRX="XIT^AMHRC5"
- SET XBIOP=0
- DO ^XBDBQUE
- +3 QUIT
- PROC ;EP - entry point for processing
- +1 SET AMHBT=$HOROLOG
- KILL AMHDISP
- +2 SET AMHCASE=0
- +3 FOR
- SET AMHCASE=$ORDER(^AMHPPHX(AMHCASE))
- IF AMHCASE'=+AMHCASE
- QUIT
- DO PROC1
- +4 SET AMHET=$HOROLOG
- +5 KILL AMHCASE
- +6 QUIT
- PROC1 ;
- +1 SET AMHR=^AMHPPHX(AMHCASE,0)
- +2 IF '$$ALLOWP^AMHUTIL(DUZ,$PIECE(AMHR,U,2))
- QUIT
- +3 IF $$DEMO^AMHUTIL1($PIECE(AMHR,U,2),$GET(AMHDEMO))
- QUIT
- +4 IF $PIECE(AMHR,U,1)=""
- QUIT
- +5 SET X=$PIECE(AMHR,U,1)
- +6 IF '$DATA(^AMHTPHF(X))
- QUIT
- +7 SET X=$PIECE(^AMHTPHF(X,0),U)
- +8 IF '$DATA(AMHDISP(X))
- SET AMHDISP(X)=""
- SET AMHDISP(X)=AMHDISP(X)+1
- SET AMHDISP(X,$PIECE(^DPT($PIECE(AMHR,U,2),0),U),$PIECE(AMHR,U,2))=""
- +9 QUIT
- PRINT ;EP - CALLED FROM XBDBQUE
- +1 SET AMH80D="-------------------------------------------------------------------------------"
- +2 SET AMHPG=0
- DO HEAD
- +3 KILL AMHQ
- +4 SET AMHX=""
- FOR
- SET AMHX=$ORDER(AMHDISP(AMHX))
- IF AMHX=""!($DATA(AMHQ))
- QUIT
- Begin DoDot:1
- +5 IF $Y>(IOSL-3)
- DO HEAD
- IF $DATA(AMHQ)
- QUIT
- +6 WRITE !!,?17,AMHX
- +7 SET AMHNAME=""
- FOR
- SET AMHNAME=$ORDER(AMHDISP(AMHX,AMHNAME))
- IF AMHNAME=""!($DATA(AMHQ))
- QUIT
- Begin DoDot:2
- +8 SET AMHP=0
- FOR
- SET AMHP=$ORDER(AMHDISP(AMHX,AMHNAME,AMHP))
- IF AMHP'=+AMHP!($DATA(AMHQ))
- QUIT
- Begin DoDot:3
- +9 IF $Y>(IOSL-3)
- DO HEAD
- +10 WRITE !?10,AMHNAME,?42,$$VAL^XBDIQ1(2,AMHP,.02),?52,$$AGE^AUPNPAT(AMHP,DT),?57,$$HRN^AUPNPAT(AMHP,DUZ(2))
- End DoDot:3
- End DoDot:2
- +11 WRITE !,"SUBCOUNT: ",AMHDISP(AMHX)
- +12 QUIT
- End DoDot:1
- DONE ;
- +1 DO EOP^AMHRDE1
- +2 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 AMHQ=""
- QUIT
- HEAD1 ;
- +1 IF $DATA(IOF)
- WRITE @IOF
- SET AMHPG=AMHPG+1
- +2 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!
- +3 WRITE "PERSONAL HISTORY LIST BY PATIENT",?44,$$FMTE^XLFDT($$NOW^XLFDT),?72,"Page ",AMHPG,!
- +4 WRITE ?10,"PATIENT",?42,"SEX",?52,"AGE",?57,"CHART NUMBER",!
- +5 WRITE AMH80D,!
- +6 QUIT
