BCHUARL ; IHS/CMI/LAB - GETLAYS DAILY ACTIVITY RECORDS ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
;Display all records for the provider, program, on this date.
;
;caller must pass BCHPROV - provider IEN
; BCHDATE - date in fileman format, no time or sec
;passed back to caller: BCHRCNT - number of records found
; BCHVRECS(n,ien)="" n is consecutive
; number
;
GATHER ;EP - called from BCHUAR
K BCHQUIT,BCHVRECS,BCHRCNT S BCHPG=0
I '$D(^BCHR("AA",$P(BCHDATE,"."),BCHPROV)) S Y=BCHDATE D DD^%DT S BCHVRECS(1,0)="No records currently on file for "_$P(^VA(200,BCHPROV,0),U)_" on "_Y S BCHRCNT=1 G EOJ
D GETRECS
EOJ K BCHQUIT,BCHPG,BCHREC,BCHV,BCHP,Y,DTOUT,DUOUT,BCHPREC,BCHHRN,X,Y,Z,%,BCHX
Q
GETRECS ;
S (BCHV,BCHRCNT)=0 F S BCHV=$O(^BCHR("AA",$P(BCHDATE,"."),BCHPROV,BCHV)) Q:BCHV'=+BCHV!($D(BCHQUIT)) S BCHRCNT=BCHRCNT+1,BCHVRECS("IDX",BCHRCNT,BCHRCNT)=BCHV,BCHREC=^BCHR(BCHV,0) D
.S BCHX=$J(BCHRCNT,3)_" "_$S($P(^BCHR(BCHV,0),U,4)]"":$E($P(^DPT($P(^BCHR(BCHV,0),U,4),0),U),1,15),$P($G(^BCHR(BCHV,11)),U)]"":$E($P(^(11),U),1,15),1:" <none> ") S BCHX=$$RBLK(BCHX,22)
.D GETHRN
.S BCHHRN=$$LBLK(BCHHRN,10)
.S BCHX=BCHX_BCHHRN_" "
.S BCHP=$O(^BCHRPROB("AD",BCHV,0)) I BCHP="" S X="<No Assessments recorded.>",X=$$RBLK(X,31),BCHX=BCHX_X
.E D GETPROB
.S BCHX=BCHX_$S($P(BCHREC,U,6)]"":$E($P(^BCHTACTL($P(BCHREC,U,6),0),U),1,4),1:" ")_" "
.S BCHX=BCHX_$J($P(BCHREC,U,11),4)
.S BCHVRECS(BCHRCNT,0)=BCHX
.Q
D EOJ
Q
GETPROB ;
S BCHP=$O(^BCHRPROB("AD",BCHV,0)),BCHPREC=^BCHRPROB(BCHP,0)
S X=$P(^BCHTPROB($P(BCHPREC,U),0),U,2)_" "
S X=X_$S($P(BCHPREC,U,4)]"":$P(^BCHTSERV($P(BCHPREC,U,4),0),U,3),1:" ")_" "
S X=X_$J($P(BCHPREC,U,5),3)_" "
S X=X_$S($P(BCHPREC,U,6)]"":$E($P(^AUTNPOV($P(BCHPREC,U,6),0),U),1,16),1:" ")
S X=$$RBLK(X,31)
S BCHX=BCHX_X
Q
GETHRN ;
S BCHHRN=""
I $P(BCHREC,U,4)]"" D Q
.I $D(^AUPNPAT($P(BCHREC,U,4),41,$P(BCHREC,U,4))) S BCHHRN=$P(^AUTTLOC($P(BCHREC,U,4),0),U,7)_$P(^AUPNPAT($P(BCHREC,U,4),41,$P(BCHREC,U,4),0),U,2) Q
.I $D(^AUPNPAT($P(BCHREC,U,4),41,DUZ(2))) S BCHHRN=$P(^AUTTLOC(DUZ(2),0),U,7)_$P(^AUPNPAT($P(BCHREC,U,4),41,DUZ(2),0),U,2) Q
.S BCHHRN="<none>"
I $P($G(^BCHR(BCHV,11)),U,12) S BCHHRN=$P($G(^BCHR(BCHV,11)),U,13)
Q
RBLK(V,L) ;EP left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
Q V
LBLK(V,L) ;left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
BCHUARL ; IHS/CMI/LAB - GETLAYS DAILY ACTIVITY RECORDS ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
+3 ;Display all records for the provider, program, on this date.
+4 ;
+5 ;caller must pass BCHPROV - provider IEN
+6 ; BCHDATE - date in fileman format, no time or sec
+7 ;passed back to caller: BCHRCNT - number of records found
+8 ; BCHVRECS(n,ien)="" n is consecutive
+9 ; number
+10 ;
GATHER ;EP - called from BCHUAR
+1 KILL BCHQUIT,BCHVRECS,BCHRCNT
SET BCHPG=0
+2 IF '$DATA(^BCHR("AA",$PIECE(BCHDATE,"."),BCHPROV))
SET Y=BCHDATE
DO DD^%DT
SET BCHVRECS(1,0)="No records currently on file for "_$PIECE(^VA(200,BCHPROV,0),U)_" on "_Y
SET BCHRCNT=1
GOTO EOJ
+3 DO GETRECS
EOJ KILL BCHQUIT,BCHPG,BCHREC,BCHV,BCHP,Y,DTOUT,DUOUT,BCHPREC,BCHHRN,X,Y,Z,%,BCHX
+1 QUIT
GETRECS ;
+1 SET (BCHV,BCHRCNT)=0
FOR
SET BCHV=$ORDER(^BCHR("AA",$PIECE(BCHDATE,"."),BCHPROV,BCHV))
IF BCHV'=+BCHV!($DATA(BCHQUIT))
QUIT
SET BCHRCNT=BCHRCNT+1
SET BCHVRECS("IDX",BCHRCNT,BCHRCNT)=BCHV
SET BCHREC=^BCHR(BCHV,0)
Begin DoDot:1
+2 SET BCHX=$JUSTIFY(BCHRCNT,3)_" "_$SELECT($PIECE(^BCHR(BCHV,0),U,4)]"":$EXTRACT($PIECE(^DPT($PIECE(^BCHR(BCHV,0),U,4),0),U),1,15),$PIECE($GET(^BCHR(BCHV,11)),U)]"":$EXTRACT($PIECE(^(11),U),1,15),1:" <none> ")
SET BCHX=$$RBLK(BCHX,22)
+3 DO GETHRN
+4 SET BCHHRN=$$LBLK(BCHHRN,10)
+5 SET BCHX=BCHX_BCHHRN_" "
+6 SET BCHP=$ORDER(^BCHRPROB("AD",BCHV,0))
IF BCHP=""
SET X="<No Assessments recorded.>"
SET X=$$RBLK(X,31)
SET BCHX=BCHX_X
+7 IF '$TEST
DO GETPROB
+8 SET BCHX=BCHX_$SELECT($PIECE(BCHREC,U,6)]"":$EXTRACT($PIECE(^BCHTACTL($PIECE(BCHREC,U,6),0),U),1,4),1:" ")_" "
+9 SET BCHX=BCHX_$JUSTIFY($PIECE(BCHREC,U,11),4)
+10 SET BCHVRECS(BCHRCNT,0)=BCHX
+11 QUIT
End DoDot:1
+12 DO EOJ
+13 QUIT
GETPROB ;
+1 SET BCHP=$ORDER(^BCHRPROB("AD",BCHV,0))
SET BCHPREC=^BCHRPROB(BCHP,0)
+2 SET X=$PIECE(^BCHTPROB($PIECE(BCHPREC,U),0),U,2)_" "
+3 SET X=X_$SELECT($PIECE(BCHPREC,U,4)]"":$PIECE(^BCHTSERV($PIECE(BCHPREC,U,4),0),U,3),1:" ")_" "
+4 SET X=X_$JUSTIFY($PIECE(BCHPREC,U,5),3)_" "
+5 SET X=X_$SELECT($PIECE(BCHPREC,U,6)]"":$EXTRACT($PIECE(^AUTNPOV($PIECE(BCHPREC,U,6),0),U),1,16),1:" ")
+6 SET X=$$RBLK(X,31)
+7 SET BCHX=BCHX_X
+8 QUIT
GETHRN ;
+1 SET BCHHRN=""
+2 IF $PIECE(BCHREC,U,4)]""
Begin DoDot:1
+3 IF $DATA(^AUPNPAT($PIECE(BCHREC,U,4),41,$PIECE(BCHREC,U,4)))
SET BCHHRN=$PIECE(^AUTTLOC($PIECE(BCHREC,U,4),0),U,7)_$PIECE(^AUPNPAT($PIECE(BCHREC,U,4),41,$PIECE(BCHREC,U,4),0),U,2)
QUIT
+4 IF $DATA(^AUPNPAT($PIECE(BCHREC,U,4),41,DUZ(2)))
SET BCHHRN=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_$PIECE(^AUPNPAT($PIECE(BCHREC,U,4),41,DUZ(2),0),U,2)
QUIT
+5 SET BCHHRN="<none>"
End DoDot:1
QUIT
+6 IF $PIECE($GET(^BCHR(BCHV,11)),U,12)
SET BCHHRN=$PIECE($GET(^BCHR(BCHV,11)),U,13)
+7 QUIT
RBLK(V,L) ;EP left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_" "
+3 QUIT V
LBLK(V,L) ;left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
