- 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
