- 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
