- APCLPYR4 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Pvt Insurance ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- Q
- ;
- PVTLOOP ;EP
- I $E(IOST)="C" W !!,"Please be patient. This may take a few minutes.",!! H 6
- S APCLINAM=$P(^AUTNINS(APCLPYR,0),U)
- K ^TMP($J,"APCLPYR")
- S APCLPAGE=0
- ;
- D HEADING
- ;
- S APCLDFN=0
- F S APCLDFN=$O(^AUPNPRVT(APCLDFN)) Q:'APCLDFN D Q:$D(DUOUT)
- .;Check if Patient is registered here
- .S Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
- .I Y="" Q
- .I Y<1 Q
- .;
- .I APCLSORT="NAME" S APCLSRT=$P(^DPT(APCLDFN,0),U)_U_APCLDFN
- .I APCLSORT="HRNO" S APCLSRT=Y
- .;
- .;--> Check for Other Insurance if user picked this option
- .I APCLOTH=1 D Q:APCLICTR>1
- ..S APCLICTR=0
- ..I +$O(^AUPNMCR("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
- ..I +$O(^AUPNMCD("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
- ..I +$O(^AUPNRRE("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
- ..S X=0
- ..F S X=$O(^AUPNPRVT("B",APCLDFN,11,X)) Q:'X S APCLICTR=APCLICTR+1
- .;
- .S APCLCTR=0
- .S APCLIEN=0
- .S APCLFLAG=0
- .F S APCLIEN=$O(^AUPNPRVT(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
- ..S APCLCTR=APCLCTR+1
- ..I $P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U)'=APCLPYR Q
- ..S APCLFLAG=APCLIEN
- ..S APCLBEG=$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,6)
- ..S APCLEND=$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,7)
- ..S APCLPVNO=$S($P($G(^AUPNPRVT(APCLDFN,11,APCLIEN,2)),U)]"":$P(^AUPNPRVT(APCLDFN,11,APCLIEN,2),U),$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,8):$P(^AUPN3PPH($P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,8),0),U,4),1:$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,2))
- ..;--> There is no Beg Date
- ..I APCLACT,APCLBEG="" S APCLFLAG=0
- ..;--> User wants to restrict to beg dates after begin date
- ..I APCLACT=2,APCLBEG<APCLBDAT S APCLFLAG=0
- ..;--> Beg Date is earlier than selected end date
- ..I APCLACT,APCLEDAT>0,APCLBEG>APCLEDAT S APCLFLAG=0
- ..;--> End date is before selected begin date
- ..I APCLACT,APCLEND>0,APCLEND<APCLBDAT S APCLFLAG=0
- ..I APCLFLAG D
- ...I APCLOTH,APCLCTR=1 D STORE
- ...I APCLOTH=0 D STORE
- ;
- S APCLCTR=0
- S APCLSRT=""
- F S APCLSRT=$O(^TMP($J,"APCLPYR",APCLSRT)) Q:APCLSRT="" D Q:$D(DUOUT)
- .S APCLIEN=0
- .F S APCLIEN=$O(^TMP($J,"APCLPYR",APCLSRT,APCLIEN)) Q:'APCLIEN D Q:$D(DUOUT)
- ..S X=^TMP($J,"APCLPYR",APCLSRT,APCLIEN)
- ..S APCLDFN=$P(X,U)
- ..S APCLBEG=$P(X,U,2)
- ..S APCLEND=$P(X,U,3)
- ..S APCLPVNO=$P(X,U,4)
- ..D WRT
- ..S APCLCTR=APCLCTR+1
- ..I $Y>(IOSL-5) D I '$D(DUOUT) D HEADING
- ...I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR
- ;
- I '$D(DUOUT) W !!,"Total: ",APCLCTR
- Q
- ;
- STORE ;
- S ^TMP($J,"APCLPYR",APCLSRT,APCLIEN)=APCLDFN_U_APCLBEG_U_APCLEND_U_APCLPVNO
- Q
- ;
- WRT ;
- W $P(^DPT(APCLDFN,0),U)
- W ?32,$J($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
- W ?40,APCLPVNO
- I APCLALL=0 D Q
- .W ?58,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
- .I APCLEND W ?68,$E(APCLEND,4,5),"/",$E(APCLEND,6,7),"/",$E(APCLEND,2,3)
- .W !
- S APCLBEG=$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,6)
- S APCLEND=$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,7)
- W ?58,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
- I APCLEND W ?68,$E(APCLEND,4,5),"/",$E(APCLEND,6,7),"/",$E(APCLEND,2,3)
- W !
- Q
- ;
- HEADING ;
- D ^XBCLS
- W !
- S X=DT
- W $E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)
- S X=$P($G(^DIC(4,APCLFAC,0)),U)
- W ?((IOM-$L(X))/2),X
- S APCLPAGE=APCLPAGE+1
- W ?70,"Page ",APCLPAGE
- W !
- ;
- S X="Patient List for "_APCLINAM
- W ?((IOM-$L(X))/2),X,!
- ;
- S X=""
- I APCLOTH=1 S X=X_"Having only this insurance"
- I X]"" W ?((IOM-$L(X))/2),X,!
- ;
- S X=""
- I APCLACT=0 S X=X_"With any eligibility dates"
- I APCLACT D
- .S X=X_"With eligibility from "
- .S X=X_$E(APCLBDAT,4,5)_"/"_$E(APCLBDAT,6,7)_"/"_$E(APCLBDAT,2,3)
- .I $G(APCLEDAT)="" Q
- .S X=X_" to "
- .S X=X_$E(APCLEDAT,4,5)_"/"_$E(APCLEDAT,6,7)_"/"_$E(APCLEDAT,2,3)
- I X]"" W ?((IOM-$L(X))/2),X,!
- ;
- W !
- ;
- W "Patient Name",?33,"HRNO",?42,"Policy #",?60,"Begin",?70,"End"
- W !
- ;
- W "------------",?32,"------",?40,"----------------",?58,"--------",?68,"--------"
- W !
- Q
- APCLPYR4 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Pvt Insurance ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 QUIT
- +3 ;
- PVTLOOP ;EP
- +1 IF $EXTRACT(IOST)="C"
- WRITE !!,"Please be patient. This may take a few minutes.",!!
- HANG 6
- +2 SET APCLINAM=$PIECE(^AUTNINS(APCLPYR,0),U)
- +3 KILL ^TMP($JOB,"APCLPYR")
- +4 SET APCLPAGE=0
- +5 ;
- +6 DO HEADING
- +7 ;
- +8 SET APCLDFN=0
- +9 FOR
- SET APCLDFN=$ORDER(^AUPNPRVT(APCLDFN))
- IF 'APCLDFN
- QUIT
- Begin DoDot:1
- +10 ;Check if Patient is registered here
- +11 SET Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
- +12 IF Y=""
- QUIT
- +13 IF Y<1
- QUIT
- +14 ;
- +15 IF APCLSORT="NAME"
- SET APCLSRT=$PIECE(^DPT(APCLDFN,0),U)_U_APCLDFN
- +16 IF APCLSORT="HRNO"
- SET APCLSRT=Y
- +17 ;
- +18 ;--> Check for Other Insurance if user picked this option
- +19 IF APCLOTH=1
- Begin DoDot:2
- +20 SET APCLICTR=0
- +21 IF +$ORDER(^AUPNMCR("B",APCLDFN,0))
- SET APCLICTR=APCLICTR+1
- +22 IF +$ORDER(^AUPNMCD("B",APCLDFN,0))
- SET APCLICTR=APCLICTR+1
- +23 IF +$ORDER(^AUPNRRE("B",APCLDFN,0))
- SET APCLICTR=APCLICTR+1
- +24 SET X=0
- +25 FOR
- SET X=$ORDER(^AUPNPRVT("B",APCLDFN,11,X))
- IF 'X
- QUIT
- SET APCLICTR=APCLICTR+1
- End DoDot:2
- IF APCLICTR>1
- QUIT
- +26 ;
- +27 SET APCLCTR=0
- +28 SET APCLIEN=0
- +29 SET APCLFLAG=0
- +30 FOR
- SET APCLIEN=$ORDER(^AUPNPRVT(APCLDFN,11,APCLIEN))
- IF 'APCLIEN
- QUIT
- Begin DoDot:2
- +31 SET APCLCTR=APCLCTR+1
- +32 IF $PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U)'=APCLPYR
- QUIT
- +33 SET APCLFLAG=APCLIEN
- +34 SET APCLBEG=$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,6)
- +35 SET APCLEND=$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,7)
- +36 SET APCLPVNO=$SELECT($PIECE(...
- ... $GET(^AUPNPRVT(APCLDFN,11,APCLIEN,2)),U)]"":$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,2),U),$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,8):$PIECE(^AUPN3PPH($PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,8),0),U,4),1:$PIECE(^AUPNPRVT(APCLDF
- N,11,APCLIEN,0),U,2))
- +37 ;--> There is no Beg Date
- +38 IF APCLACT
- IF APCLBEG=""
- SET APCLFLAG=0
- +39 ;--> User wants to restrict to beg dates after begin date
- +40 IF APCLACT=2
- IF APCLBEG<APCLBDAT
- SET APCLFLAG=0
- +41 ;--> Beg Date is earlier than selected end date
- +42 IF APCLACT
- IF APCLEDAT>0
- IF APCLBEG>APCLEDAT
- SET APCLFLAG=0
- +43 ;--> End date is before selected begin date
- +44 IF APCLACT
- IF APCLEND>0
- IF APCLEND<APCLBDAT
- SET APCLFLAG=0
- +45 IF APCLFLAG
- Begin DoDot:3
- +46 IF APCLOTH
- IF APCLCTR=1
- DO STORE
- +47 IF APCLOTH=0
- DO STORE
- End DoDot:3
- End DoDot:2
- End DoDot:1
- IF $DATA(DUOUT)
- QUIT
- +48 ;
- +49 SET APCLCTR=0
- +50 SET APCLSRT=""
- +51 FOR
- SET APCLSRT=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT))
- IF APCLSRT=""
- QUIT
- Begin DoDot:1
- +52 SET APCLIEN=0
- +53 FOR
- SET APCLIEN=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT,APCLIEN))
- IF 'APCLIEN
- QUIT
- Begin DoDot:2
- +54 SET X=^TMP($JOB,"APCLPYR",APCLSRT,APCLIEN)
- +55 SET APCLDFN=$PIECE(X,U)
- +56 SET APCLBEG=$PIECE(X,U,2)
- +57 SET APCLEND=$PIECE(X,U,3)
- +58 SET APCLPVNO=$PIECE(X,U,4)
- +59 DO WRT
- +60 SET APCLCTR=APCLCTR+1
- +61 IF $Y>(IOSL-5)
- Begin DoDot:3
- +62 IF $EXTRACT(IOST)="C"
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- End DoDot:3
- IF '$DATA(DUOUT)
- DO HEADING
- End DoDot:2
- IF $DATA(DUOUT)
- QUIT
- End DoDot:1
- IF $DATA(DUOUT)
- QUIT
- +63 ;
- +64 IF '$DATA(DUOUT)
- WRITE !!,"Total: ",APCLCTR
- +65 QUIT
- +66 ;
- STORE ;
- +1 SET ^TMP($JOB,"APCLPYR",APCLSRT,APCLIEN)=APCLDFN_U_APCLBEG_U_APCLEND_U_APCLPVNO
- +2 QUIT
- +3 ;
- WRT ;
- +1 WRITE $PIECE(^DPT(APCLDFN,0),U)
- +2 WRITE ?32,$JUSTIFY($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
- +3 WRITE ?40,APCLPVNO
- +4 IF APCLALL=0
- Begin DoDot:1
- +5 WRITE ?58,$EXTRACT(APCLBEG,4,5),"/",$EXTRACT(APCLBEG,6,7),"/",$EXTRACT(APCLBEG,2,3)
- +6 IF APCLEND
- WRITE ?68,$EXTRACT(APCLEND,4,5),"/",$EXTRACT(APCLEND,6,7),"/",$EXTRACT(APCLEND,2,3)
- +7 WRITE !
- End DoDot:1
- QUIT
- +8 SET APCLBEG=$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,6)
- +9 SET APCLEND=$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,7)
- +10 WRITE ?58,$EXTRACT(APCLBEG,4,5),"/",$EXTRACT(APCLBEG,6,7),"/",$EXTRACT(APCLBEG,2,3)
- +11 IF APCLEND
- WRITE ?68,$EXTRACT(APCLEND,4,5),"/",$EXTRACT(APCLEND,6,7),"/",$EXTRACT(APCLEND,2,3)
- +12 WRITE !
- +13 QUIT
- +14 ;
- HEADING ;
- +1 DO ^XBCLS
- +2 WRITE !
- +3 SET X=DT
- +4 WRITE $EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)
- +5 SET X=$PIECE($GET(^DIC(4,APCLFAC,0)),U)
- +6 WRITE ?((IOM-$LENGTH(X))/2),X
- +7 SET APCLPAGE=APCLPAGE+1
- +8 WRITE ?70,"Page ",APCLPAGE
- +9 WRITE !
- +10 ;
- +11 SET X="Patient List for "_APCLINAM
- +12 WRITE ?((IOM-$LENGTH(X))/2),X,!
- +13 ;
- +14 SET X=""
- +15 IF APCLOTH=1
- SET X=X_"Having only this insurance"
- +16 IF X]""
- WRITE ?((IOM-$LENGTH(X))/2),X,!
- +17 ;
- +18 SET X=""
- +19 IF APCLACT=0
- SET X=X_"With any eligibility dates"
- +20 IF APCLACT
- Begin DoDot:1
- +21 SET X=X_"With eligibility from "
- +22 SET X=X_$EXTRACT(APCLBDAT,4,5)_"/"_$EXTRACT(APCLBDAT,6,7)_"/"_$EXTRACT(APCLBDAT,2,3)
- +23 IF $GET(APCLEDAT)=""
- QUIT
- +24 SET X=X_" to "
- +25 SET X=X_$EXTRACT(APCLEDAT,4,5)_"/"_$EXTRACT(APCLEDAT,6,7)_"/"_$EXTRACT(APCLEDAT,2,3)
- End DoDot:1
- +26 IF X]""
- WRITE ?((IOM-$LENGTH(X))/2),X,!
- +27 ;
- +28 WRITE !
- +29 ;
- +30 WRITE "Patient Name",?33,"HRNO",?42,"Policy #",?60,"Begin",?70,"End"
- +31 WRITE !
- +32 ;
- +33 WRITE "------------",?32,"------",?40,"----------------",?58,"--------",?68,"--------"
- +34 WRITE !
- +35 QUIT
