AGRPTPRV ; IHS/ASDS/EFG - PRIVATE INSURANCE REPORT ;
;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
;W !!,"SELECT A RANGE OF NAMES FOR WHICH YOU WOULD LIKE TO PRINT PRIVATE INSURANCE.",!,"ENTER THE BEGINNING AND ENDING NAMES AS THEY ARE REQUESTED."
;CC W !!,"START WITH WHAT PATIENT NAME? " D PTLK^AG
;G:'$D(DFN) END1 S AGBEG=$P(^DPT(DFN,0),U)
;D W !!,"END WITH WHAT PATIENT NAME? " D PTLK^AG
;G:'$D(DFN) END1 S AGEND=$P(^DPT(DFN,0),U) I AGBEG]AGEND W !!,*7,"THE ENDING NAME PRECEDES THE BEGINNING NAME." G CC
;BEGIN NEW CODE IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
PTS ;
S $P(AG("="),"=",81)=""
S $P(AG("-"),"-",81)=""
S DIR(0)="S^B:ALL BENEFICIARIES;A:ACTIVE PATIENTS ONLY;D:DECEASED AND INACTIVE PATIENTS ONLY"
S DIR("A")="SELECT DESIRED ACCOUNTS"
D ^DIR K DIR
S AGPTS=Y
Q:$D(DTOUT)!(Y="^")!(Y="/.,")!(Y="^^")
;END NEW CODE IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
S AGIO=IO,AG("HAT")=""
DEV S %ZIS="OPQ" D ^%ZIS I POP S IOP=ION D ^%ZIS Q
G:'$D(IO("Q")) START K IO("Q") I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
X ^%ZOSF("UCI") S ZTRTN="START^AGRPTPRV",ZTUCI=Y,ZTIO="",ZTDESC="PRIVATE INS. from "_AGBEG_" to "_AGEND_".",AGQIO=IO F G="AGBEG","AGEND","AGQIO" S ZTSAVE(G)=""
D ^%ZTLOAD G:'$D(ZTSK) DEV K AG,AGBEG,AGEND,AGIO,AGQIO,G,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZTUCI D ^%ZISC
Q
START ;EP - From TaskMan.
;K ^TMP($J) F I=0:0 S I=$O(^AUPNPRVT("B",I)) Q:+I'=I Q:$G(^DPT(I,0))="" I AGBEG']$P(^DPT(I,0),U),$P(^(0),U)']AGEND,$O(^AUPNPRVT(I,11,0)) S ^TMP($J,$P(^DPT(I,0),U),I)=""
;BEGIN NEW CODE IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
S (DFN,AGTOT)=0 K ^TMP($J)
F S DFN=$O(^AUPNPRVT(DFN)) Q:+DFN<1 D
.S AGFLAG=0
.;if there is an HRN for this person and data in VA PATIENT
.I $D(^AUPNPAT(DFN,41,DUZ(2))),$D(^DPT(DFN,0)) D
..I AGPTS="A" D ;active people only
...I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)="",$P($G(^DPT(DFN,.35)),U)="" S AGFLAG=1
..I AGPTS="D" D ;deceased/inactive only
...I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)'=""!($P($G(^DPT(DFN,.35)),U)'="") S AGFLAG=1
..I AGPTS="B" S AGFLAG=1
..I AGFLAG S ^TMP($J,$P(^DPT(DFN,0),U),DFN)="",AGTOT=AGTOT+1
;END NEW CODE IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
I $D(AGQIO) F AGZ("I")=1:1 S IOP=AGQIO D ^%ZIS Q:'POP H 30
S (AGPGPG,AGCONT)=0,AGNM=" ",X=$P(^DIC(4,DUZ(2),0),U) D CTR^AG S AG("LOC")=X,AG("USR")=$P(^VA(200,DUZ,0),U),AGBM=IOSL-10 I $D(AGIO),AGIO=IO S AGBM=IOSL-4
;X ^%ZOSF("UCI") S X="UCI: "_$P(Y,",") D CTR^AG S AGUCI=X,X="from "_AGBEG_" to "_AGEND D CTR^AG S AGTTL=X U IO D LINES^AG,NOW^AG S X=AGTIME D CTR^AG S AGTIME=X D HDR
X ^%ZOSF("UCI") S X="UCI: "_$P(Y,",") S AGUCI=X D NOW^AG S AGTIME=Y S AGTTL="" ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
F C=0:1 S AGNM=$O(^TMP($J,AGNM)) G:AGNM="" END D NAME G END1:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) I $Y>AGBM D RTRN^AG G END1:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) D HDR
NAME F DFN=0:0 S DFN=$O(^TMP($J,AGNM,DFN)) Q:'DFN D HDR W !,$P(^DPT(DFN,0),U) S A=0 D PT,FAC Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT)
Q
PT S A=$O(^AUPNPRVT(DFN,11,A)) Q:+A'=A S AGINS=^(A,0) G PT:$P(AGINS,U)="",PT:'$D(^AUTNINS($P(AGINS,U),0)) S AGCO=$P(^(0),U) I $Y>AGBM D RTRN^AG Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) S AGCONT=1 D HDR
W !?5,AGCO,?36,$P(AGINS,U,2),!?5,$P(AGINS,U,4)
I $P(AGINS,U,5)]"",$D(^AUTTRLSH($P(AGINS,U,5),0)) W ?36,$E($P(^(0),U),1,12)
S Y=$P(AGINS,U,6) D DD^%DT W ?53,Y S Y=$P(AGINS,U,7) D DD^%DT W ?67,Y,!
I $P(AGINS,U,3) W ?5,$P(^AUTTPIC($P(AGINS,U,3),0),U)
S ^TMP($J,0,AGCO)=$S($D(^TMP($J,0,AGCO)):^(AGCO)+1,1:1)
G PT
FAC F I=0:0 S I=$O(^AUPNPAT(DFN,41,I)) Q:+I'=I S R=^(I,0) W !?20,$J($P(R,U,2),6),?30,$P(^DIC(4,$P(R,U),0),U) W:'$O(^AUPNPAT(DFN,41,I)) !,AG("-"),! I $Y>AGBM D RTRN^AG Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) S:$O(^AUPNPAT(DFN,41,I)) AGCONT=1 D HDR
Q
END D RTRN^AG,HDR W !!,"PATIENTS WITH PRIVATE INSURANCE : ",C,!! S T=0,AGCO="" F I=0:0 S AGCO=$O(^TMP($J,0,AGCO)) Q:AGCO="" W !?5,AGCO,$E("........................................",1,40-$X-($L(^(AGCO)))),^(AGCO) S T=T+^(AGCO)
W !?31,"==========",!?35,$J(T,5) K AG("HAT") D RTRN^AG W $$S^AGVDF("IOF")
END1 D ^%ZISC K ^TMP($J),A,AG,AGBEG,AGBM,AGEND,AGIO,AGTIME,C,AGCO,AGCONT,DA,AG("DENT"),DFN,DIC,DLOUT,DR,G,AGL,I,AGINS,AG("LKERR"),AG("LKDATA"),AG("LKPRINT"),AG("LOC"),AGNM,AGPCC,AGPGPG,R,AGTTL,AGUCI,AG("USR"),X,Y D:$D(ZTQUEUED) KILL^%ZTLOAD
Q
HDR S AGPGPG=AGPGPG+1
W $$S^AGVDF("IOF"),AG("USR"),?70,"page ",AGPGPG
W !,AG("LOC"),!?31,"PRIVATE INSURANCE"
S X=AGUCI D CTR^AG W !,X
S X=AGTIME D CTR^AG W !,X
W !!?17,"REPORT CONTAINS "_$S(AGPTS="B":"ALL BENEFICIARIES",AGPTS="A":"ACTIVE PATIENTS ONLY",AGPTS="D":"DECEASED AND INACTIVE PATIENTS ONLY") ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
W !!!?5,"COMPANY",?36,"POLICY NUMBER",!?5,"NAME OF INSURED",?36,"RELATIONSHIP",?53,"FROM",?67,"TO",!?5,"COVERAGE",!?21,"CHART SITE",!,AG("="),!
I AGCONT W !,$P(^DPT(DFN,0),U)," (cont.)" S AGCONT=0
Q
AGRPTPRV ; IHS/ASDS/EFG - PRIVATE INSURANCE REPORT ;
+1 ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
+2 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
+3 ;W !!,"SELECT A RANGE OF NAMES FOR WHICH YOU WOULD LIKE TO PRINT PRIVATE INSURANCE.",!,"ENTER THE BEGINNING AND ENDING NAMES AS THEY ARE REQUESTED."
+4 ;CC W !!,"START WITH WHAT PATIENT NAME? " D PTLK^AG
+5 ;G:'$D(DFN) END1 S AGBEG=$P(^DPT(DFN,0),U)
+6 ;D W !!,"END WITH WHAT PATIENT NAME? " D PTLK^AG
+7 ;G:'$D(DFN) END1 S AGEND=$P(^DPT(DFN,0),U) I AGBEG]AGEND W !!,*7,"THE ENDING NAME PRECEDES THE BEGINNING NAME." G CC
+8 ;BEGIN NEW CODE IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
PTS ;
+1 SET $PIECE(AG("="),"=",81)=""
+2 SET $PIECE(AG("-"),"-",81)=""
+3 SET DIR(0)="S^B:ALL BENEFICIARIES;A:ACTIVE PATIENTS ONLY;D:DECEASED AND INACTIVE PATIENTS ONLY"
+4 SET DIR("A")="SELECT DESIRED ACCOUNTS"
+5 DO ^DIR
KILL DIR
+6 SET AGPTS=Y
+7 IF $DATA(DTOUT)!(Y="^")!(Y="/.,")!(Y="^^")
QUIT
+8 ;END NEW CODE IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
+9 SET AGIO=IO
SET AG("HAT")=""
DEV SET %ZIS="OPQ"
DO ^%ZIS
IF POP
SET IOP=ION
DO ^%ZIS
QUIT
+1 IF '$DATA(IO("Q"))
GOTO START
KILL IO("Q")
IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+2 XECUTE ^%ZOSF("UCI")
SET ZTRTN="START^AGRPTPRV"
SET ZTUCI=Y
SET ZTIO=""
SET ZTDESC="PRIVATE INS. from "_AGBEG_" to "_AGEND_"."
SET AGQIO=IO
FOR G="AGBEG","AGEND","AGQIO"
SET ZTSAVE(G)=""
+3 DO ^%ZTLOAD
IF '$DATA(ZTSK)
GOTO DEV
KILL AG,AGBEG,AGEND,AGIO,AGQIO,G,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZTUCI
DO ^%ZISC
+4 QUIT
START ;EP - From TaskMan.
+1 ;K ^TMP($J) F I=0:0 S I=$O(^AUPNPRVT("B",I)) Q:+I'=I Q:$G(^DPT(I,0))="" I AGBEG']$P(^DPT(I,0),U),$P(^(0),U)']AGEND,$O(^AUPNPRVT(I,11,0)) S ^TMP($J,$P(^DPT(I,0),U),I)=""
+2 ;BEGIN NEW CODE IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
+3 SET (DFN,AGTOT)=0
KILL ^TMP($JOB)
+4 FOR
SET DFN=$ORDER(^AUPNPRVT(DFN))
IF +DFN<1
QUIT
Begin DoDot:1
+5 SET AGFLAG=0
+6 ;if there is an HRN for this person and data in VA PATIENT
+7 IF $DATA(^AUPNPAT(DFN,41,DUZ(2)))
IF $DATA(^DPT(DFN,0))
Begin DoDot:2
+8 ;active people only
IF AGPTS="A"
Begin DoDot:3
+9 IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)=""
IF $PIECE($GET(^DPT(DFN,.35)),U)=""
SET AGFLAG=1
End DoDot:3
+10 ;deceased/inactive only
IF AGPTS="D"
Begin DoDot:3
+11 IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)'=""!($PIECE($GET(^DPT(DFN,.35)),U)'="")
SET AGFLAG=1
End DoDot:3
+12 IF AGPTS="B"
SET AGFLAG=1
+13 IF AGFLAG
SET ^TMP($JOB,$PIECE(^DPT(DFN,0),U),DFN)=""
SET AGTOT=AGTOT+1
End DoDot:2
End DoDot:1
+14 ;END NEW CODE IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
+15 IF $DATA(AGQIO)
FOR AGZ("I")=1:1
SET IOP=AGQIO
DO ^%ZIS
IF 'POP
QUIT
HANG 30
+16 SET (AGPGPG,AGCONT)=0
SET AGNM=" "
SET X=$PIECE(^DIC(4,DUZ(2),0),U)
DO CTR^AG
SET AG("LOC")=X
SET AG("USR")=$PIECE(^VA(200,DUZ,0),U)
SET AGBM=IOSL-10
IF $DATA(AGIO)
IF AGIO=IO
SET AGBM=IOSL-4
+17 ;X ^%ZOSF("UCI") S X="UCI: "_$P(Y,",") D CTR^AG S AGUCI=X,X="from "_AGBEG_" to "_AGEND D CTR^AG S AGTTL=X U IO D LINES^AG,NOW^AG S X=AGTIME D CTR^AG S AGTIME=X D HDR
+18 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
XECUTE ^%ZOSF("UCI")
SET X="UCI: "_$PIECE(Y,",")
SET AGUCI=X
DO NOW^AG
SET AGTIME=Y
SET AGTTL=""
+19 FOR C=0:1
SET AGNM=$ORDER(^TMP($JOB,AGNM))
IF AGNM=""
GOTO END
DO NAME
IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
GOTO END1
IF $Y>AGBM
DO RTRN^AG
IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
GOTO END1
DO HDR
NAME FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,AGNM,DFN))
IF 'DFN
QUIT
DO HDR
WRITE !,$PIECE(^DPT(DFN,0),U)
SET A=0
DO PT
DO FAC
IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
QUIT
+1 QUIT
PT SET A=$ORDER(^AUPNPRVT(DFN,11,A))
IF +A'=A
QUIT
SET AGINS=^(A,0)
IF $PIECE(AGINS,U)=""
GOTO PT
IF '$DATA(^AUTNINS($PIECE(AGINS,U),0))
GOTO PT
SET AGCO=$PIECE(^(0),U)
IF $Y>AGBM
DO RTRN^AG
IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
QUIT
SET AGCONT=1
DO HDR
+1 WRITE !?5,AGCO,?36,$PIECE(AGINS,U,2),!?5,$PIECE(AGINS,U,4)
+2 IF $PIECE(AGINS,U,5)]""
IF $DATA(^AUTTRLSH($PIECE(AGINS,U,5),0))
WRITE ?36,$EXTRACT($PIECE(^(0),U),1,12)
+3 SET Y=$PIECE(AGINS,U,6)
DO DD^%DT
WRITE ?53,Y
SET Y=$PIECE(AGINS,U,7)
DO DD^%DT
WRITE ?67,Y,!
+4 IF $PIECE(AGINS,U,3)
WRITE ?5,$PIECE(^AUTTPIC($PIECE(AGINS,U,3),0),U)
+5 SET ^TMP($JOB,0,AGCO)=$SELECT($DATA(^TMP($JOB,0,AGCO)):^(AGCO)+1,1:1)
+6 GOTO PT
FAC FOR I=0:0
SET I=$ORDER(^AUPNPAT(DFN,41,I))
IF +I'=I
QUIT
SET R=^(I,0)
WRITE !?20,$JUSTIFY($PIECE(R,U,2),6),?30,$PIECE(^DIC(4,$PIECE(R,U),0),U)
IF '$ORDER(^AUPNPAT(DFN,41,I))
WRITE !,AG("-"),!
IF $Y>AGBM
DO RTRN^AG
IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
QUIT
IF $ORDER(^AUPNPAT(DFN,41,I))
SET AGCONT=1
DO HDR
+1 QUIT
END DO RTRN^AG
DO HDR
WRITE !!,"PATIENTS WITH PRIVATE INSURANCE : ",C,!!
SET T=0
SET AGCO=""
FOR I=0:0
SET AGCO=$ORDER(^TMP($JOB,0,AGCO))
IF AGCO=""
QUIT
WRITE !?5,AGCO,$EXTRACT("........................................",1,40-$X-($LENGTH(^(AGCO)))),^(AGCO)
SET T=T+^(AGCO)
+1 WRITE !?31,"==========",!?35,$JUSTIFY(T,5)
KILL AG("HAT")
DO RTRN^AG
WRITE $$S^AGVDF("IOF")
END1 DO ^%ZISC
KILL ^TMP($JOB),A,AG,AGBEG,AGBM,AGEND,AGIO,AGTIME,C,AGCO,AGCONT,DA,AG("DENT"),DFN,DIC,DLOUT,DR,G,AGL,I,AGINS,AG("LKERR"),AG("LKDATA"),AG("LKPRINT"),AG("LOC"),AGNM,AGPCC,AGPGPG,R,AGTTL,AGUCI,AG("USR"),X,Y
IF $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+1 QUIT
HDR SET AGPGPG=AGPGPG+1
+1 WRITE $$S^AGVDF("IOF"),AG("USR"),?70,"page ",AGPGPG
+2 WRITE !,AG("LOC"),!?31,"PRIVATE INSURANCE"
+3 SET X=AGUCI
DO CTR^AG
WRITE !,X
+4 SET X=AGTIME
DO CTR^AG
WRITE !,X
+5 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 11 PAGE 11
WRITE !!?17,"REPORT CONTAINS "_$SELECT(AGPTS="B":"ALL BENEFICIARIES",AGPTS="A":"ACTIVE PATIENTS ONLY",AGPTS="D":"DECEASED AND INACTIVE PATIENTS ONLY")
+6 WRITE !!!?5,"COMPANY",?36,"POLICY NUMBER",!?5,"NAME OF INSURED",?36,"RELATIONSHIP",?53,"FROM",?67,"TO",!?5,"COVERAGE",!?21,"CHART SITE",!,AG("="),!
+7 IF AGCONT
WRITE !,$PIECE(^DPT(DFN,0),U)," (cont.)"
SET AGCONT=0
+8 QUIT
