AMHRP1 ; IHS/CMI/LAB - DETAILED/BRIEF LISTING OF RECORDS, REPORT 1 ;
;;4.0;IHS BEHAVIORAL HEALTH;**4,5**;JUN 02, 2010;Build 18
;
;
BDRL ;type of report
W !!?5,"Report Print Selection."
S DIR(0)="S^D:Detailed (132 column print);B:Brief (80 column print)",DIR("A")="Type of Report to Print",DIR("B")="D" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) S AMHQUIT=1 Q
S AMHRTYPE=Y
Q
PRINT ;EP
S AMHCW=$S(AMHRTYPE="B":80,1:132)
;
D COVPAGE^AMHRPTCP
I '$D(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS")) G DONE
S (AMHRSRT,AMHFRST)="",(AMHPG,AMHRCNT)=0 K AMHQUIT
F S AMHRSRT=$O(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHRSRT)) Q:AMHRSRT=""!($D(AMHQUIT)) D PRINT1
G:$D(AMHQUIT) DONE
I $Y>(IOSL-6) D HEADER G:$D(AMHQUIT) DONE
DONE ;
D DONE^AMHLEIN,^AMHEKL
K ^XTMP("AMHRPT",AMHJOB,AMHBT)
K AMHBT,AMHBTH,AMHJOB,AMHET
Q
PRINT1 ;
;get readable sort variable
S AMHSRTR="<NONE AVAILABLE>",AMHR=$O(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHRSRT,"")) I AMHR]"" S AMHCRIT=AMHSORT D
.S AMHR0=^AMHREC(AMHR,0),DFN=$P(AMHR0,U,8) X:$D(^AMHSORT(AMHSORT,3)) ^AMHSORT(AMHSORT,3)
.Q
S (AMHSCNT,AMHR)=0 I $G(AMHSPAG)!($D(AMHFRST)) D HEADER Q:$D(AMHQUIT)
K AMHFRST
F S AMHR=$O(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHRSRT,AMHR)) Q:AMHR=""!($D(AMHQUIT)) S AMHR0=^AMHREC(AMHR,0) D @("PRINT"_AMHRTYPE)
I $Y>(IOSL-3) D HEADER Q:$D(AMHQUIT)
W:$G(AMHSPAG) !!!,"SUB-TOTAL for ",AMHSORV," ",AMHRSRT,": ",AMHSCNT
Q
PRINTB ;
S:$G(AMHSPAG) AMHSCNT=AMHSCNT+1
I $Y>(IOSL-6) D HEADER Q:$D(AMHQUIT)
S AMHRCNT=AMHRCNT+1
W !,$E($P(AMHR0,U),4,5),"/",$E($P(AMHR0,U),6,7),"/",$E($P(AMHR0,U),2,3),?10,$$PPINI^AMHUTIL(AMHR)
W ?15,$S($P(^AUTTLOC($P(AMHR0,U,4),0),U,7)]"":$P(^(0),U,7),1:$E($P(^AUTTLOC($P(AMHR0,U,4),0),U),1,4)) W:$P(AMHR0,U,8) ?20,$E($P(^DPT($P(AMHR0,U,8),0),U),1,12)
W ?34,$S($P(AMHR0,U,6)]"":$P(^AMHTACT($P(AMHR0,U,6),0),U),1:""),?37,$S($P(AMHR0,U,7)]"":$E($P(^AMHTSET($P(AMHR0,U,7),0),U),1,4),1:""),?42,$P(AMHR0,U,12)
I $P(AMHR0,U,8)]"" D
.I $D(^AUPNPAT($P(AMHR0,U,8),41,$P(AMHR0,U,4))) W ?46,$P(^AUTTLOC($P(AMHR0,U,4),0),U,7),$P(^AUPNPAT($P(AMHR0,U,8),41,$P(AMHR0,U,4),0),U,2) Q
.I $D(^AUPNPAT($P(AMHR0,U,8),41,DUZ(2))) W ?46,$P(^AUTTLOC(DUZ(2),0),U,7),$P(^AUPNPAT($P(AMHR0,U,8),41,DUZ(2),0),U,2) Q
.W ?47,"<*****>"
E W ?46,"-----"
S AMHP=$O(^AMHRPRO("AD",AMHR,0)) I AMHP="" W ?57,"No Problems recorded" Q
W ?57,$P(^AMHPROB($P(^AMHRPRO(AMHP,0),U),0),U) W:$P(^AMHRPRO(AMHP,0),U,4) ?66,$E($$GET1^DIQ(9002011.01,AMHP,.04),1,14) D
.F S AMHP=$O(^AMHRPRO("AD",AMHR,AMHP)) Q:AMHP'=+AMHP W !?57,$P(^AMHPROB($P(^AMHRPRO(AMHP,0),U),0),U) W ?66,$E($$GET1^DIQ(9002011.01,AMHP,.04),1,14)
.Q
Q
;
PRINTD ;detailed print
S:$G(AMHSPAG) AMHSCNT=AMHSCNT+1
I $Y>(IOSL-6) D HEADER Q:$D(AMHQUIT)
S AMHRCNT=AMHRCNT+1
W !,$E($P(AMHR0,U),4,5),"/",$E($P(AMHR0,U),6,7),"/",$E($P(AMHR0,U),2,3) I $P($P(AMHR0,U),".")]"" W ?9,"@" S Y=$P(AMHR0,U) D DD^%DT W $P(Y,"@",2)
W ?16,$E($$PPNAME^AMHUTIL(AMHR),1,17),?34,$$PPCLSC^AMHUTIL(AMHR)
W ?39,$P(AMHR0,U,2),?42,$S($P(^AUTTLOC($P(AMHR0,U,4),0),U,7)]"":$P(^(0),U,7),1:$E($P(^AUTTLOC($P(AMHR0,U,4),0),U),1,4)) W:$P(AMHR0,U,8) ?47,$E($P(^DPT($P(AMHR0,U,8),0),U),1,12)
W ?60,$S($P(AMHR0,U,6)]"":$P(^AMHTACT($P(AMHR0,U,6),0),U),1:""),?64,$P(AMHR0,U,12),?68,$S($P(AMHR0,U,7)]"":$E($P(^AMHTSET($P(AMHR0,U,7),0),U),1,4),1:"")
I $P(AMHR0,U,8)]"" D
.I $D(^AUPNPAT($P(AMHR0,U,8),41,$P(AMHR0,U,4))) W ?74,$P(^AUTTLOC($P(AMHR0,U,4),0),U,7),$P(^AUPNPAT($P(AMHR0,U,8),41,$P(AMHR0,U,4),0),U,2) G SEX
.I $D(^AUPNPAT($P(AMHR0,U,8),41,DUZ(2))) W ?74,$P(^AUTTLOC(DUZ(2),0),U,7),$P(^AUPNPAT($P(AMHR0,U,8),41,DUZ(2),0),U,2) G SEX
.W ?74,"<******>"
SEX .W ?86,$P(^DPT($P(AMHR0,U,8),0),U,2)
.K ^UTILITY("DIQ1",$J) S DA=$P(AMHR0,U,8),DR=1102.99,DIC="^AUPNPAT(",DIQ(0)="E" D EN^DIQ1
.I $D(^UTILITY("DIQ1",$J)) W ?90,^UTILITY("DIQ1",$J,9000001,$P(AMHR0,U,8),1102.99,"E") K ^UTILITY("DIQ1",$J)
.Q
E W ?74,"-----"
S AMHP=$O(^AMHRPRO("AD",AMHR,0)) I AMHP="" W ?100,"No Problems recorded" Q
W ?93,$P(^AMHPROB($P(^AMHRPRO(AMHP,0),U),0),U) W:$P(^AMHRPRO(AMHP,0),U,4) ?102,$E($$GET1^DIQ(9002011.01,AMHP,.04),1,30) D
.F S AMHP=$O(^AMHRPRO("AD",AMHR,AMHP)) Q:AMHP'=+AMHP W !?93,$P(^AMHPROB($P(^AMHRPRO(AMHP,0),U),0),U) W ?102,$E($$GET1^DIQ(9002011.01,AMHP,.04),1,30)
.Q
Q
D HEADER^AMHRP11
Q
AMHRP1 ; IHS/CMI/LAB - DETAILED/BRIEF LISTING OF RECORDS, REPORT 1 ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**4,5**;JUN 02, 2010;Build 18
+2 ;
+3 ;
BDRL ;type of report
+1 WRITE !!?5,"Report Print Selection."
+2 SET DIR(0)="S^D:Detailed (132 column print);B:Brief (80 column print)"
SET DIR("A")="Type of Report to Print"
SET DIR("B")="D"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
SET AMHQUIT=1
QUIT
+4 SET AMHRTYPE=Y
+5 QUIT
PRINT ;EP
+1 SET AMHCW=$SELECT(AMHRTYPE="B":80,1:132)
+2 ;
+3 DO COVPAGE^AMHRPTCP
+4 IF '$DATA(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS"))
GOTO DONE
+5 SET (AMHRSRT,AMHFRST)=""
SET (AMHPG,AMHRCNT)=0
KILL AMHQUIT
+6 FOR
SET AMHRSRT=$ORDER(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHRSRT))
IF AMHRSRT=""!($DATA(AMHQUIT))
QUIT
DO PRINT1
+7 IF $DATA(AMHQUIT)
GOTO DONE
+8 IF $Y>(IOSL-6)
DO HEADER
IF $DATA(AMHQUIT)
GOTO DONE
DONE ;
+1 DO DONE^AMHLEIN
DO ^AMHEKL
+2 KILL ^XTMP("AMHRPT",AMHJOB,AMHBT)
+3 KILL AMHBT,AMHBTH,AMHJOB,AMHET
+4 QUIT
PRINT1 ;
+1 ;get readable sort variable
+2 SET AMHSRTR="<NONE AVAILABLE>"
SET AMHR=$ORDER(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHRSRT,""))
IF AMHR]""
SET AMHCRIT=AMHSORT
Begin DoDot:1
+3 SET AMHR0=^AMHREC(AMHR,0)
SET DFN=$PIECE(AMHR0,U,8)
IF $DATA(^AMHSORT(AMHSORT,3))
XECUTE ^AMHSORT(AMHSORT,3)
+4 QUIT
End DoDot:1
+5 SET (AMHSCNT,AMHR)=0
IF $GET(AMHSPAG)!($DATA(AMHFRST))
DO HEADER
IF $DATA(AMHQUIT)
QUIT
+6 KILL AMHFRST
+7 FOR
SET AMHR=$ORDER(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHRSRT,AMHR))
IF AMHR=""!($DATA(AMHQUIT))
QUIT
SET AMHR0=^AMHREC(AMHR,0)
DO @("PRINT"_AMHRTYPE)
+8 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(AMHQUIT)
QUIT
+9 IF $GET(AMHSPAG)
WRITE !!!,"SUB-TOTAL for ",AMHSORV," ",AMHRSRT,": ",AMHSCNT
+10 QUIT
PRINTB ;
+1 IF $GET(AMHSPAG)
SET AMHSCNT=AMHSCNT+1
+2 IF $Y>(IOSL-6)
DO HEADER
IF $DATA(AMHQUIT)
QUIT
+3 SET AMHRCNT=AMHRCNT+1
+4 WRITE !,$EXTRACT($PIECE(AMHR0,U),4,5),"/",$EXTRACT($PIECE(AMHR0,U),6,7),"/",$EXTRACT($PIECE(AMHR0,U),2,3),?10,$$PPINI^AMHUTIL(AMHR)
+5 WRITE ?15,$SELECT($PIECE(^AUTTLOC($PIECE(AMHR0,U,4),0),U,7)]"":$PIECE(^(0),U,7),1:$EXTRACT($PIECE(^AUTTLOC($PIECE(AMHR0,U,4),0),U),1,4))
IF $PIECE(AMHR0,U,8)
WRITE ?20,$EXTRACT($PIECE(^DPT($PIECE(AMHR0,U,8),0),U),1,12)
+6 WRITE ?34,$SELECT($PIECE(AMHR0,U,6)]"":$PIECE(^AMHTACT($PIECE(AMHR0,U,6),0),U),1:""),?37,$SELECT($PIECE(AMHR0,U,7)]"":$EXTRACT($PIECE(^AMHTSET($PIECE(AMHR0,U,7),0),U),1,4),1:""),?42,$PIECE(AMHR0,U,12)
+7 IF $PIECE(AMHR0,U,8)]""
Begin DoDot:1
+8 IF $DATA(^AUPNPAT($PIECE(AMHR0,U,8),41,$PIECE(AMHR0,U,4)))
WRITE ?46,$PIECE(^AUTTLOC($PIECE(AMHR0,U,4),0),U,7),$PIECE(^AUPNPAT($PIECE(AMHR0,U,8),41,$PIECE(AMHR0,U,4),0),U,2)
QUIT
+9 IF $DATA(^AUPNPAT($PIECE(AMHR0,U,8),41,DUZ(2)))
WRITE ?46,$PIECE(^AUTTLOC(DUZ(2),0),U,7),$PIECE(^AUPNPAT($PIECE(AMHR0,U,8),41,DUZ(2),0),U,2)
QUIT
+10 WRITE ?47,"<*****>"
End DoDot:1
+11 IF '$TEST
WRITE ?46,"-----"
+12 SET AMHP=$ORDER(^AMHRPRO("AD",AMHR,0))
IF AMHP=""
WRITE ?57,"No Problems recorded"
QUIT
+13 WRITE ?57,$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHP,0),U),0),U)
IF $PIECE(^AMHRPRO(AMHP,0),U,4)
WRITE ?66,$EXTRACT($$GET1^DIQ(9002011.01,AMHP,.04),1,14)
Begin DoDot:1
+14 FOR
SET AMHP=$ORDER(^AMHRPRO("AD",AMHR,AMHP))
IF AMHP'=+AMHP
QUIT
WRITE !?57,$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHP,0),U),0),U)
WRITE ?66,$EXTRACT($$GET1^DIQ(9002011.01,AMHP,.04),1,14)
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
PRINTD ;detailed print
+1 IF $GET(AMHSPAG)
SET AMHSCNT=AMHSCNT+1
+2 IF $Y>(IOSL-6)
DO HEADER
IF $DATA(AMHQUIT)
QUIT
+3 SET AMHRCNT=AMHRCNT+1
+4 WRITE !,$EXTRACT($PIECE(AMHR0,U),4,5),"/",$EXTRACT($PIECE(AMHR0,U),6,7),"/",$EXTRACT($PIECE(AMHR0,U),2,3)
IF $PIECE($PIECE(AMHR0,U),".")]""
WRITE ?9,"@"
SET Y=$PIECE(AMHR0,U)
DO DD^%DT
WRITE $PIECE(Y,"@",2)
+5 WRITE ?16,$EXTRACT($$PPNAME^AMHUTIL(AMHR),1,17),?34,$$PPCLSC^AMHUTIL(AMHR)
+6 WRITE ?39,$PIECE(AMHR0,U,2),?42,$SELECT($PIECE(^AUTTLOC($PIECE(AMHR0,U,4),0),U,7)]"":$PIECE(^(0),U,7),1:$EXTRACT($PIECE(^AUTTLOC($PIECE(AMHR0,U,4),0),U),1,4))
IF $PIECE(AMHR0,U,8)
WRITE ?47,$EXTRACT($PIECE(^DPT($PIECE(AMHR0,U,8),0),U),1,12)
+7 WRITE ?60,$SELECT($PIECE(AMHR0,U,6)]"":$PIECE(^AMHTACT($PIECE(AMHR0,U,6),0),U),1:""),?64,$PIECE(AMHR0,U,12),?68,$SELECT($PIECE(AMHR0,U,7)]"":$EXTRACT($PIECE(^AMHTSET($PIECE(AMHR0,U,7),0),U),1,4),1:"")
+8 IF $PIECE(AMHR0,U,8)]""
Begin DoDot:1
+9 IF $DATA(^AUPNPAT($PIECE(AMHR0,U,8),41,$PIECE(AMHR0,U,4)))
WRITE ?74,$PIECE(^AUTTLOC($PIECE(AMHR0,U,4),0),U,7),$PIECE(^AUPNPAT($PIECE(AMHR0,U,8),41,$PIECE(AMHR0,U,4),0),U,2)
GOTO SEX
+10 IF $DATA(^AUPNPAT($PIECE(AMHR0,U,8),41,DUZ(2)))
WRITE ?74,$PIECE(^AUTTLOC(DUZ(2),0),U,7),$PIECE(^AUPNPAT($PIECE(AMHR0,U,8),41,DUZ(2),0),U,2)
GOTO SEX
+11 WRITE ?74,"<******>"
SEX WRITE ?86,$PIECE(^DPT($PIECE(AMHR0,U,8),0),U,2)
+1 KILL ^UTILITY("DIQ1",$JOB)
SET DA=$PIECE(AMHR0,U,8)
SET DR=1102.99
SET DIC="^AUPNPAT("
SET DIQ(0)="E"
DO EN^DIQ1
+2 IF $DATA(^UTILITY("DIQ1",$JOB))
WRITE ?90,^UTILITY("DIQ1",$JOB,9000001,$PIECE(AMHR0,U,8),1102.99,"E")
KILL ^UTILITY("DIQ1",$JOB)
+3 QUIT
End DoDot:1
+4 IF '$TEST
WRITE ?74,"-----"
+5 SET AMHP=$ORDER(^AMHRPRO("AD",AMHR,0))
IF AMHP=""
WRITE ?100,"No Problems recorded"
QUIT
+6 WRITE ?93,$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHP,0),U),0),U)
IF $PIECE(^AMHRPRO(AMHP,0),U,4)
WRITE ?102,$EXTRACT($$GET1^DIQ(9002011.01,AMHP,.04),1,30)
Begin DoDot:1
+7 FOR
SET AMHP=$ORDER(^AMHRPRO("AD",AMHR,AMHP))
IF AMHP'=+AMHP
QUIT
WRITE !?93,$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHP,0),U),0),U)
WRITE ?102,$EXTRACT($$GET1^DIQ(9002011.01,AMHP,.04),1,30)
+8 QUIT
End DoDot:1
+9 QUIT
+1 DO HEADER^AMHRP11
+2 QUIT
