ACHSEPAT ; IHS/ITSC/PMF - PRINT EOBRS BY PATIENT ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22**;JUN 11, 2001;Build 43
;ACHS*3.1*22 Modification to fix error if patient is not defined
;
K ACHSPAT,DFN
W $G(IORVON),!,"THIS REPORT WILL ONLY INCLUDE PROCESSED DOCUMENTS. ANY UNPROCESSED",!,"DOCUMENT WILL HAVE TO BE PRINTED USING ANOTHER OPTION.",$G(IORVOFF),!!!
D PTLK^ACHS
Q:'$D(DFN)
S ACHSPAT=DFN
W !
S (ACHSDIEN,ACHSTIEN,ACHSX)=0
PAT1 ;
S ACHSDIEN=$O(^ACHSF(DUZ(2),"EOBP",ACHSPAT,ACHSDIEN))
I ACHSDIEN="" S I=1,ACHSPATI=0 G PATSEL ;ACHS*3.1*22 ADDED IF TEST
G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN)) PAT1 ;ACHS*3.1*22
S ACHSTIEN=0
PAT2 ;
S ACHSTIEN=$O(^ACHSF(DUZ(2),"EOBP",ACHSPAT,ACHSDIEN,ACHSTIEN))
G PAT1:ACHSTIEN=""
S ACHSDAT=0
PAT3 ;
S ACHSDAT=$O(^ACHSF(DUZ(2),"EOBP",ACHSPAT,ACHSDIEN,ACHSTIEN,ACHSDAT))
G:ACHSDAT="" PAT2
S ACHSX=ACHSX+1,ACHSPAT(ACHSX)=ACHSDIEN_"^"_ACHSTIEN_"^"_ACHSDAT
G PAT3
;
PAT4 ;NOT USED KEPT FOR FUTURE ENHANCEMENTS
;S ACHSPATI=$O(^ACHSEOBE("EOBP",DFN,ACHSPATI)) G PATSEL:ACHSPATI=""
;S ACHSX=ACHSX+1,ACHSPATI(ACHSX)=DFN_"^"_ACHSPATI
;G PAT4
;
PATSEL ;
I ACHSX=0 G PATNO
I ACHSX=1 S ACHSLST=1 G PATPR ;S:$D(ACHSPAT(ACHS)) PATPR
W !!,"ENTRY #",?10,"DOCUMENT #",?27,"PATIENT NAME",?56,"CHART #",?67,"TRANS DATE",!,$$REPEAT^XLFSTR("-",79)
;S ACHSY=0
;F I=1:1:ACHSX D:$D(ACHSPAT(I)) PATSEL1 S ACHSY=ACHSY+1 I ACHSY#10=0 W !!,"Press <RETURN> To Continue" D READ^ACHSFU G PATSEL:Y="" G DIR:Y?1N.N ;D:$D(ACHSPATI(I)) PATSEL2
F I=I:1:ACHSX D:$D(ACHSPAT(I)) PATSEL1 I I#10=0 D RTRN^ACHS Q:$D(DUOUT) ;ACHS*3.1*22
DIR ;
S ACHSLST=$$DIR^XBDIR("L^1:"_I,"ENTER NUMBER(S) OF SELECTION(S)","","","","",1) ;ACHS*3.1*22
G PATEND:$D(DUOUT)!$D(DTOUT),PATPR
;
PATSEL1 ;
S ACHSDIEN=$P(ACHSPAT(I),U,1),ACHSTIEN=$P(ACHSPAT(I),U,2),ACHSDAT=$P(ACHSPAT(I),U,3),Y=$$FMTE^XLFDT(9999999-ACHSDAT)
S ACHSPAT=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,22),ACHSCHRT=$P(^AUPNPAT(ACHSPAT,41,DUZ(2),0),U,2),ACHSDOC=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,14)_"-"_ACHSFC_"-"_$P(^(0),U,1)
S ACHSPAT=$P(^DPT(ACHSPAT,0),U,1)
D PATSELPR
Q
;
PATSEL2 ;NOT USED KEPT FOR FUTURE ENHANCEMENTS
;S ACHSPATI=ACHSPATI(I)
;S DFN=$P(ACHSPATI,U,1),ACHSEPAT=$P(ACHSPATI,U,2)
;S ACHSPAT=$P(^DPT(DFN,0),U,1),ACHSDOC=$P(^ACHSEOBE(ACHSEPAT,0),U,1),ACHSCHRT=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),ACHSDAT=$P(^ACHSEOBE(ACHSEPAT,0),U,8)
;S Y=$$FMTE^XLFDT($S($E(ACHSDAT,1,2)>50:2,$E(ACHSDAT,1,2)<50:3)_ACHSDAT)
;D PATSELPR
Q
;
PATSELPR ;
W !,I,".",?10,ACHSDOC,?27,ACHSPAT,?57,ACHSCHRT,?67,Y
Q
;
PATPR ;
D DEV,BRPT^ACHSFU
G:Y=0!($D(DUOUT))!($D(DTOUT))!($D(DIRUT)) PATEND
S ACHSXX=0
PATPR1 ;
S ACHSXX=ACHSXX+1
S I=$P(ACHSLST,",",ACHSXX)
G:I="" PATEND
D:$D(ACHSPAT(I)) PATPR2
;D:$D(ACHSPATI(I)) PATPR3
G PATPR1
;
PATPR2 ;
S ACHSDIEN=$P(ACHSPAT(I),U,1),ACHSTIEN=$P(ACHSPAT(I),U,2)
D ^ACHSEOBA,^ACHSEOB2
Q
;
PATPR3 ;NOT USED KEPT FOR FUTURE ENHANCEMENTS
;S ACHSNON=ACHSEPAT
;D ^ACHSEOBE,^ACHSEOB2
Q
;
PATNO ;
W !!,"NO EOBRS PROCESSED FOR THIS PATIENT",!!
I $$DIR^XBDIR("E","Press RETURN...")
G PATEND
;
DEV ;
W !!
S %ZIS="P"
D ^%ZIS
S ACHSEOIO=IO
Q
;
PATEND ;
D ^%ZISC,EN^XBVK("ACHS"),^ACHSVAR
Q
;
ACHSEPAT ; IHS/ITSC/PMF - PRINT EOBRS BY PATIENT ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22**;JUN 11, 2001;Build 43
+2 ;ACHS*3.1*22 Modification to fix error if patient is not defined
+3 ;
+4 KILL ACHSPAT,DFN
+5 WRITE $GET(IORVON),!,"THIS REPORT WILL ONLY INCLUDE PROCESSED DOCUMENTS. ANY UNPROCESSED",!,"DOCUMENT WILL HAVE TO BE PRINTED USING ANOTHER OPTION.",$GET(IORVOFF),!!!
+6 DO PTLK^ACHS
+7 IF '$DATA(DFN)
QUIT
+8 SET ACHSPAT=DFN
+9 WRITE !
+10 SET (ACHSDIEN,ACHSTIEN,ACHSX)=0
PAT1 ;
+1 SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"EOBP",ACHSPAT,ACHSDIEN))
+2 ;ACHS*3.1*22 ADDED IF TEST
IF ACHSDIEN=""
SET I=1
SET ACHSPATI=0
GOTO PATSEL
+3 ;ACHS*3.1*22
IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN))
GOTO PAT1
+4 SET ACHSTIEN=0
PAT2 ;
+1 SET ACHSTIEN=$ORDER(^ACHSF(DUZ(2),"EOBP",ACHSPAT,ACHSDIEN,ACHSTIEN))
+2 IF ACHSTIEN=""
GOTO PAT1
+3 SET ACHSDAT=0
PAT3 ;
+1 SET ACHSDAT=$ORDER(^ACHSF(DUZ(2),"EOBP",ACHSPAT,ACHSDIEN,ACHSTIEN,ACHSDAT))
+2 IF ACHSDAT=""
GOTO PAT2
+3 SET ACHSX=ACHSX+1
SET ACHSPAT(ACHSX)=ACHSDIEN_"^"_ACHSTIEN_"^"_ACHSDAT
+4 GOTO PAT3
+5 ;
PAT4 ;NOT USED KEPT FOR FUTURE ENHANCEMENTS
+1 ;S ACHSPATI=$O(^ACHSEOBE("EOBP",DFN,ACHSPATI)) G PATSEL:ACHSPATI=""
+2 ;S ACHSX=ACHSX+1,ACHSPATI(ACHSX)=DFN_"^"_ACHSPATI
+3 ;G PAT4
+4 ;
PATSEL ;
+1 IF ACHSX=0
GOTO PATNO
+2 ;S:$D(ACHSPAT(ACHS)) PATPR
IF ACHSX=1
SET ACHSLST=1
GOTO PATPR
+3 WRITE !!,"ENTRY #",?10,"DOCUMENT #",?27,"PATIENT NAME",?56,"CHART #",?67,"TRANS DATE",!,$$REPEAT^XLFSTR("-",79)
+4 ;S ACHSY=0
+5 ;F I=1:1:ACHSX D:$D(ACHSPAT(I)) PATSEL1 S ACHSY=ACHSY+1 I ACHSY#10=0 W !!,"Press <RETURN> To Continue" D READ^ACHSFU G PATSEL:Y="" G DIR:Y?1N.N ;D:$D(ACHSPATI(I)) PATSEL2
+6 ;ACHS*3.1*22
FOR I=I:1:ACHSX
IF $DATA(ACHSPAT(I))
DO PATSEL1
IF I#10=0
DO RTRN^ACHS
IF $DATA(DUOUT)
QUIT
DIR ;
+1 ;ACHS*3.1*22
SET ACHSLST=$$DIR^XBDIR("L^1:"_I,"ENTER NUMBER(S) OF SELECTION(S)","","","","",1)
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO PATEND
GOTO PATPR
+3 ;
PATSEL1 ;
+1 SET ACHSDIEN=$PIECE(ACHSPAT(I),U,1)
SET ACHSTIEN=$PIECE(ACHSPAT(I),U,2)
SET ACHSDAT=$PIECE(ACHSPAT(I),U,3)
SET Y=$$FMTE^XLFDT(9999999-ACHSDAT)
+2 SET ACHSPAT=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,22)
SET ACHSCHRT=$PIECE(^AUPNPAT(ACHSPAT,41,DUZ(2),0),U,2)
SET ACHSDOC=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,14)_"-"_ACHSFC_"-"_$PIECE(^(0),U,1)
+3 SET ACHSPAT=$PIECE(^DPT(ACHSPAT,0),U,1)
+4 DO PATSELPR
+5 QUIT
+6 ;
PATSEL2 ;NOT USED KEPT FOR FUTURE ENHANCEMENTS
+1 ;S ACHSPATI=ACHSPATI(I)
+2 ;S DFN=$P(ACHSPATI,U,1),ACHSEPAT=$P(ACHSPATI,U,2)
+3 ;S ACHSPAT=$P(^DPT(DFN,0),U,1),ACHSDOC=$P(^ACHSEOBE(ACHSEPAT,0),U,1),ACHSCHRT=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),ACHSDAT=$P(^ACHSEOBE(ACHSEPAT,0),U,8)
+4 ;S Y=$$FMTE^XLFDT($S($E(ACHSDAT,1,2)>50:2,$E(ACHSDAT,1,2)<50:3)_ACHSDAT)
+5 ;D PATSELPR
+6 QUIT
+7 ;
PATSELPR ;
+1 WRITE !,I,".",?10,ACHSDOC,?27,ACHSPAT,?57,ACHSCHRT,?67,Y
+2 QUIT
+3 ;
PATPR ;
+1 DO DEV
DO BRPT^ACHSFU
+2 IF Y=0!($DATA(DUOUT))!($DATA(DTOUT))!($DATA(DIRUT))
GOTO PATEND
+3 SET ACHSXX=0
PATPR1 ;
+1 SET ACHSXX=ACHSXX+1
+2 SET I=$PIECE(ACHSLST,",",ACHSXX)
+3 IF I=""
GOTO PATEND
+4 IF $DATA(ACHSPAT(I))
DO PATPR2
+5 ;D:$D(ACHSPATI(I)) PATPR3
+6 GOTO PATPR1
+7 ;
PATPR2 ;
+1 SET ACHSDIEN=$PIECE(ACHSPAT(I),U,1)
SET ACHSTIEN=$PIECE(ACHSPAT(I),U,2)
+2 DO ^ACHSEOBA
DO ^ACHSEOB2
+3 QUIT
+4 ;
PATPR3 ;NOT USED KEPT FOR FUTURE ENHANCEMENTS
+1 ;S ACHSNON=ACHSEPAT
+2 ;D ^ACHSEOBE,^ACHSEOB2
+3 QUIT
+4 ;
PATNO ;
+1 WRITE !!,"NO EOBRS PROCESSED FOR THIS PATIENT",!!
+2 IF $$DIR^XBDIR("E","Press RETURN...")
+3 GOTO PATEND
+4 ;
DEV ;
+1 WRITE !!
+2 SET %ZIS="P"
+3 DO ^%ZIS
+4 SET ACHSEOIO=IO
+5 QUIT
+6 ;
PATEND ;
+1 DO ^%ZISC
DO EN^XBVK("ACHS")
DO ^ACHSVAR
+2 QUIT
+3 ;
