- AMHRP4P ; IHS/CMI/LAB - print active client list (using case open/close) 03 Jun 2009 12:10 PM ;
- ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
- ;
- ;
- PRINT ;
- START ;
- S X1=DT,X2=-365 D C^%DTC S AMHBD=X,AMHED=DT
- S Y=AMHBD D DD^%DT S AMHBDD=Y S Y=AMHED D DD^%DT S AMHEDD=Y
- S AMH80D="-------------------------------------------------------------------------------"
- S AMHPG=0 D HEAD
- I '$D(^XTMP("AMHRP4",AMHJOB,AMHBTH)) W !!,"NO PATIENTS TO REPORT" G DONE
- S DFN="" K AMHQ
- S AMHNAME="" F S AMHNAME=$O(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME)) Q:AMHNAME=""!($D(AMHQ)) D
- .S DFN=0 F S DFN=$O(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME,DFN)) Q:DFN'=+DFN!($D(AMHQ)) D DFN
- G:$D(AMHQ) DONE
- W !!,"Total Number of Patients: ",AMHPCNT,!
- W "Total Number of Cases: ",AMHCCNT,!
- DONE D DONE^AMHLEIN,^AMHEKL
- K ^XTMP("AMHRP4",AMHJOB,AMHBTH),AMHJOB,AMHBTH
- Q
- DFN ;
- S AMHCASE=0 F S AMHCASE=$O(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME,DFN,AMHCASE)) Q:AMHCASE'=+AMHCASE!($D(AMHQ)) D PRN
- Q
- PRN ;
- I $Y>(IOSL-4) D HEAD Q:$D(AMHQ)
- S AMHHRCN=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^(0),U,2),1:"<none>")
- W !,$E($P(^DPT(DFN,0),U),1,15),?18,AMHHRCN
- S AMHX=^AMHPCASE(AMHCASE,0)
- W ?26,$P(^DPT(DFN,0),U,2) S Y=$P(^DPT(DFN,0),U,3) W ?28,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
- S Y=$P(AMHX,U) W ?38,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
- S Y=$P(AMHX,U,4) I Y]"" W ?48,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
- VSTS ; process visits
- K AMHRLOC,AMHPRV,AMHPROB
- S AMHR=0,AMHBDO=9999999-AMHBD,AMHEDO=9999999-AMHED,AMHSD=AMHED-1,AMHSD=AMHSD_".9999",AMHRCNT=0
- F S AMHSD=$O(^AMHREC("AE",DFN,AMHSD)) Q:$P(AMHSD,".")>AMHBDO!(AMHSD="") D
- .S AMHR=0 F S AMHR=$O(^AMHREC("AE",DFN,AMHSD,AMHR)) Q:AMHR'=+AMHR D
- ..S AMHRCNT=AMHRCNT+1 ;COUNT # VISITS
- ..;TABLE LOC SEEN
- ..I $P(^AMHREC(AMHR,0),U,4)]"",'$D(AMHRLOC($P(^DIC(4,$P(^(0),U,4),0),U))) S AMHRLOC($P(^DIC(4,$P(^AMHREC(AMHR,0),U,4),0),U))=""
- ..;TABLE PROVIDERS
- ..S AMHP=0 F S AMHP=$O(^AMHRPROV("AD",AMHR,AMHP)) Q:AMHP'=+AMHP S P=$P(^AMHRPROV(AMHP,0),U),AMHPRV($P(^VA(200,P,0),U))=""
- ..;TABLE PROBLEMS
- ..S AMHP=0 F S AMHP=$O(^AMHRPRO("AD",AMHR,AMHP)) Q:AMHP'=+AMHP S P=$P(^AMHRPRO(AMHP,0),U),AMHPROB($P(^AMHPROB(P,0),U))=""
- ..Q
- .Q
- K AMHLINE,AMHPRNT,AMHPRNM
- S AMHLINE(1)=""
- K AMHPRNM S X="",C=0,K=11 F S X=$O(AMHPRV(X)) Q:X="" S C=C+1,AMHPRNM(C)=X
- D LINE
- K AMHPRNM S X="",C=0,K=7 F S X=$O(AMHPROB(X)) Q:X="" S C=C+1,AMHPRNM(C)=X
- D LINE
- S X=0 F S X=$O(AMHLINE(X)) Q:X'=+X W ?60,AMHLINE(X),!
- I $Y>(IOSL-3) D HEAD Q:$D(AMHQ)
- W ?2,"Case Provider: ",$$VAL^XBDIQ1(9002011.58,AMHCASE,.08),?50,"Next Case Review: ",$S($P(AMHX,U,12)]"":$$FMTE^XLFDT($P(AMHX,U,12),"2E"),1:""),!
- Q
- LINE ;
- I '$D(AMHPRNM) S AMHPRNT="--" D
- .S AMHPRNT=$E(AMHPRNT,1,10) D
- ..S J=$L(AMHPRNT),AMHLINE(1)=AMHLINE(1)_AMHPRNT F I=J:1:K S AMHLINE(1)=AMHLINE(1)_" "
- S X=0 F S X=$O(AMHPRNM(X)) Q:X'=+X D
- .I X=1 D Q
- ..S AMHPRNT=$E(AMHPRNM(1),1,10) D
- ...S J=$L(AMHPRNT),AMHLINE(1)=AMHLINE(1)_AMHPRNT F I=J:1:K S AMHLINE(1)=AMHLINE(1)_" "
- .S AMHPRNT=$E(AMHPRNM(X),1,10) D
- ..I '$D(AMHLINE(X)) S AMHLINE(X)="",$P(AMHLINE(X)," ",($L(AMHLINE(1))-K))=""
- ..S J=$L(AMHPRNT),AMHLINE(X)=AMHLINE(X)_AMHPRNT F I=J:1:K S AMHLINE(X)=AMHLINE(X)_" "
- S X=1 F S X=$O(AMHLINE(X)) Q:X'=+X I $L(AMHLINE(X))<$L(AMHLINE(1)) S K=$L(AMHLINE(X))+1,J=$L(AMHLINE(1)) F I=K:1:J S AMHLINE(X)=AMHLINE(X)_" "
- 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 !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
- W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",AMHPG,!
- W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
- ;W ?15,"Encounter Dates: ",AMHBDD," to ",AMHEDD,!
- I AMHPROG]"" S X="Program: "_$$EXTSET^XBFUNC(9002011.58,.03,AMHPROG) W $$CTR(X,80),!
- W ?10,"ACTIVE CLIENT LIST (CASE OPEN DATE WITH NO CASE CLOSED DATE)"
- PIH W !,"PATIENT NAME",?18,"CHART",?25,"SEX",?31,"DOB",?38,"CASE OPEN",?48,"CASE ADMIT",?60,"PROVIDER",?72,"PROBLEM"
- W !?18,"NUMBER",?38,"DATE",?48,"DATE",?60,"SEEN",?72,"CODES",!,AMH80D
- Q
- CTR(X,Y) ;EP - Center X in a field Y wide.
- Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
- ;----------
- AMHRP4P ; IHS/CMI/LAB - print active client list (using case open/close) 03 Jun 2009 12:10 PM ;
- +1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
- +2 ;
- +3 ;
- PRINT ;
- START ;
- +1 SET X1=DT
- SET X2=-365
- DO C^%DTC
- SET AMHBD=X
- SET AMHED=DT
- +2 SET Y=AMHBD
- DO DD^%DT
- SET AMHBDD=Y
- SET Y=AMHED
- DO DD^%DT
- SET AMHEDD=Y
- +3 SET AMH80D="-------------------------------------------------------------------------------"
- +4 SET AMHPG=0
- DO HEAD
- +5 IF '$DATA(^XTMP("AMHRP4",AMHJOB,AMHBTH))
- WRITE !!,"NO PATIENTS TO REPORT"
- GOTO DONE
- +6 SET DFN=""
- KILL AMHQ
- +7 SET AMHNAME=""
- FOR
- SET AMHNAME=$ORDER(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME))
- IF AMHNAME=""!($DATA(AMHQ))
- QUIT
- Begin DoDot:1
- +8 SET DFN=0
- FOR
- SET DFN=$ORDER(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME,DFN))
- IF DFN'=+DFN!($DATA(AMHQ))
- QUIT
- DO DFN
- End DoDot:1
- +9 IF $DATA(AMHQ)
- GOTO DONE
- +10 WRITE !!,"Total Number of Patients: ",AMHPCNT,!
- +11 WRITE "Total Number of Cases: ",AMHCCNT,!
- DONE DO DONE^AMHLEIN
- DO ^AMHEKL
- +1 KILL ^XTMP("AMHRP4",AMHJOB,AMHBTH),AMHJOB,AMHBTH
- +2 QUIT
- DFN ;
- +1 SET AMHCASE=0
- FOR
- SET AMHCASE=$ORDER(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME,DFN,AMHCASE))
- IF AMHCASE'=+AMHCASE!($DATA(AMHQ))
- QUIT
- DO PRN
- +2 QUIT
- PRN ;
- +1 IF $Y>(IOSL-4)
- DO HEAD
- IF $DATA(AMHQ)
- QUIT
- +2 SET AMHHRCN=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^(0),U,2),1:"<none>")
- +3 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,15),?18,AMHHRCN
- +4 SET AMHX=^AMHPCASE(AMHCASE,0)
- +5 WRITE ?26,$PIECE(^DPT(DFN,0),U,2)
- SET Y=$PIECE(^DPT(DFN,0),U,3)
- WRITE ?28,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
- +6 SET Y=$PIECE(AMHX,U)
- WRITE ?38,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
- +7 SET Y=$PIECE(AMHX,U,4)
- IF Y]""
- WRITE ?48,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
- VSTS ; process visits
- +1 KILL AMHRLOC,AMHPRV,AMHPROB
- +2 SET AMHR=0
- SET AMHBDO=9999999-AMHBD
- SET AMHEDO=9999999-AMHED
- SET AMHSD=AMHED-1
- SET AMHSD=AMHSD_".9999"
- SET AMHRCNT=0
- +3 FOR
- SET AMHSD=$ORDER(^AMHREC("AE",DFN,AMHSD))
- IF $PIECE(AMHSD,".")>AMHBDO!(AMHSD="")
- QUIT
- Begin DoDot:1
- +4 SET AMHR=0
- FOR
- SET AMHR=$ORDER(^AMHREC("AE",DFN,AMHSD,AMHR))
- IF AMHR'=+AMHR
- QUIT
- Begin DoDot:2
- +5 ;COUNT # VISITS
- SET AMHRCNT=AMHRCNT+1
- +6 ;TABLE LOC SEEN
- +7 IF $PIECE(^AMHREC(AMHR,0),U,4)]""
- IF '$DATA(AMHRLOC($PIECE(^DIC(4,$PIECE(^(0),U,4),0),U)))
- SET AMHRLOC($PIECE(^DIC(4,$PIECE(^AMHREC(AMHR,0),U,4),0),U))=""
- +8 ;TABLE PROVIDERS
- +9 SET AMHP=0
- FOR
- SET AMHP=$ORDER(^AMHRPROV("AD",AMHR,AMHP))
- IF AMHP'=+AMHP
- QUIT
- SET P=$PIECE(^AMHRPROV(AMHP,0),U)
- SET AMHPRV($PIECE(^VA(200,P,0),U))=""
- +10 ;TABLE PROBLEMS
- +11 SET AMHP=0
- FOR
- SET AMHP=$ORDER(^AMHRPRO("AD",AMHR,AMHP))
- IF AMHP'=+AMHP
- QUIT
- SET P=$PIECE(^AMHRPRO(AMHP,0),U)
- SET AMHPROB($PIECE(^AMHPROB(P,0),U))=""
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 KILL AMHLINE,AMHPRNT,AMHPRNM
- +15 SET AMHLINE(1)=""
- +16 KILL AMHPRNM
- SET X=""
- SET C=0
- SET K=11
- FOR
- SET X=$ORDER(AMHPRV(X))
- IF X=""
- QUIT
- SET C=C+1
- SET AMHPRNM(C)=X
- +17 DO LINE
- +18 KILL AMHPRNM
- SET X=""
- SET C=0
- SET K=7
- FOR
- SET X=$ORDER(AMHPROB(X))
- IF X=""
- QUIT
- SET C=C+1
- SET AMHPRNM(C)=X
- +19 DO LINE
- +20 SET X=0
- FOR
- SET X=$ORDER(AMHLINE(X))
- IF X'=+X
- QUIT
- WRITE ?60,AMHLINE(X),!
- +21 IF $Y>(IOSL-3)
- DO HEAD
- IF $DATA(AMHQ)
- QUIT
- +22 WRITE ?2,"Case Provider: ",$$VAL^XBDIQ1(9002011.58,AMHCASE,.08),?50,"Next Case Review: ",$SELECT($PIECE(AMHX,U,12)]"":$$FMTE^XLFDT($PIECE(AMHX,U,12),"2E"),1:""),!
- +23 QUIT
- LINE ;
- +1 IF '$DATA(AMHPRNM)
- SET AMHPRNT="--"
- Begin DoDot:1
- +2 SET AMHPRNT=$EXTRACT(AMHPRNT,1,10)
- Begin DoDot:2
- +3 SET J=$LENGTH(AMHPRNT)
- SET AMHLINE(1)=AMHLINE(1)_AMHPRNT
- FOR I=J:1:K
- SET AMHLINE(1)=AMHLINE(1)_" "
- End DoDot:2
- End DoDot:1
- +4 SET X=0
- FOR
- SET X=$ORDER(AMHPRNM(X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +5 IF X=1
- Begin DoDot:2
- +6 SET AMHPRNT=$EXTRACT(AMHPRNM(1),1,10)
- Begin DoDot:3
- +7 SET J=$LENGTH(AMHPRNT)
- SET AMHLINE(1)=AMHLINE(1)_AMHPRNT
- FOR I=J:1:K
- SET AMHLINE(1)=AMHLINE(1)_" "
- End DoDot:3
- End DoDot:2
- QUIT
- +8 SET AMHPRNT=$EXTRACT(AMHPRNM(X),1,10)
- Begin DoDot:2
- +9 IF '$DATA(AMHLINE(X))
- SET AMHLINE(X)=""
- SET $PIECE(AMHLINE(X)," ",($LENGTH(AMHLINE(1))-K))=""
- +10 SET J=$LENGTH(AMHPRNT)
- SET AMHLINE(X)=AMHLINE(X)_AMHPRNT
- FOR I=J:1:K
- SET AMHLINE(X)=AMHLINE(X)_" "
- End DoDot:2
- End DoDot:1
- +11 SET X=1
- FOR
- SET X=$ORDER(AMHLINE(X))
- IF X'=+X
- QUIT
- IF $LENGTH(AMHLINE(X))<$LENGTH(AMHLINE(1))
- SET K=$LENGTH(AMHLINE(X))+1
- SET J=$LENGTH(AMHLINE(1))
- FOR I=K:1:J
- SET AMHLINE(X)=AMHLINE(X)_" "
- +12 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 !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
- +3 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",AMHPG,!
- +4 WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!
- +5 ;W ?15,"Encounter Dates: ",AMHBDD," to ",AMHEDD,!
- +6 IF AMHPROG]""
- SET X="Program: "_$$EXTSET^XBFUNC(9002011.58,.03,AMHPROG)
- WRITE $$CTR(X,80),!
- +7 WRITE ?10,"ACTIVE CLIENT LIST (CASE OPEN DATE WITH NO CASE CLOSED DATE)"
- PIH WRITE !,"PATIENT NAME",?18,"CHART",?25,"SEX",?31,"DOB",?38,"CASE OPEN",?48,"CASE ADMIT",?60,"PROVIDER",?72,"PROBLEM"
- +1 WRITE !?18,"NUMBER",?38,"DATE",?48,"DATE",?60,"SEEN",?72,"CODES",!,AMH80D
- +2 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 ;----------
