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