Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLPYR2

APCLPYR2.m

Go to the documentation of this file. 
  1. APCLPYR2 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Medicare ;
  1.  ;;2.0;IHS PCC SUITE;**21**;MAY 14, 2009;Build 34
  1.  Q
  1.  ;
  1. MRALOOP ;EP
  1.  I $E(IOST)="C" W !!,"Please be patient.  This may take a few minutes.",!! H 6
  1.  S APCLINAM="Medicare Part A"
  1.  K ^TMP($J,"APCLPYR")
  1.  S APCLPAGE=0
  1.  ;
  1.  D HEADING
  1.  ;
  1.  S APCLDFN=0
  1.  F  S APCLDFN=$O(^AUPNMCR(APCLDFN)) Q:'APCLDFN  D  Q:$D(DUOUT)
  1.  .;Check if Patient is registered here
  1.  .S Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
  1.  .I Y="" Q
  1.  .I Y<1 Q
  1.  .;
  1.  .I APCLSORT="NAME" S APCLSRT=$P(^DPT(APCLDFN,0),U)_U_APCLDFN
  1.  .I APCLSORT="HRNO" S APCLSRT=Y
  1.  .;
  1.  .;-->  Check for Other Insurance if user picked this option
  1.  .I APCLOTH=1 D  Q:APCLICTR>1
  1.  ..S APCLICTR=0
  1.  ..I +$O(^AUPNMCR("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
  1.  ..I +$O(^AUPNMCD("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
  1.  ..I +$O(^AUPNRRE("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
  1.  ..S X=0
  1.  ..F  S X=$O(^AUPNPRVT("B",APCLDFN,11,X)) Q:'X  S APCLICTR=APCLICTR+1
  1.  .;
  1.  .S APCLCTR=0
  1.  .S APCLIEN=0
  1.  .S APCLFLAG=0
  1.  .F  S APCLIEN=$O(^AUPNMCR(APCLDFN,11,APCLIEN)) Q:'APCLIEN  D
  1.  ..S APCLCTR=APCLCTR+1
  1.  ..I $P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="A" Q
  1.  ..S APCLFLAG=APCLIEN
  1.  ..S APCLBEG=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
  1.  ..S APCLEND=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
  1.  ..;--> There is no Beg Date 
  1.  ..I APCLACT,APCLBEG="" S APCLFLAG=0
  1.  ..;-->  User wants to restrict to beg elig dates after beg date
  1.  ..I APCLACT=2,APCLBEG<APCLBDAT S APCLFLAG=0
  1.  ..;--> Beg Date is earlier than selected end date 
  1.  ..I APCLACT,APCLEDAT>0,APCLBEG>APCLEDAT S APCLFLAG=0
  1.  ..;--> End date is before selected begin date 
  1.  ..I APCLACT,APCLEND>0,APCLEND<APCLBDAT S APCLFLAG=0
  1.  .I APCLFLAG D
  1.  ..;S APCLMRNO=$P(^AUPNMCR(APCLDFN,0),U,3)
  1.  ..S APCLMRNO=$$GETMCR^AGUTL(APCLDFN)  ;IHS/CMI/LAB NMCI PATCH 21
  1.  ..S APCLMRSF=""
  1.  ..S X=$P(^AUPNMCR(APCLDFN,0),U,4)
  1.  ..I X S APCLMRSF=$G(^AUTTMCS(X,0))
  1.  ..I APCLOTH,APCLCTR=1 D STORE
  1.  ..I APCLOTH=0 D STORE
  1.  ;
  1.  S APCLCTR=0
  1.  S APCLSRT=""
  1.  F  S APCLSRT=$O(^TMP($J,"APCLPYR",APCLSRT)) Q:APCLSRT=""  D  Q:$D(DUOUT)
  1.  .S X=^TMP($J,"APCLPYR",APCLSRT)
  1.  .S APCLDFN=$P(X,U)
  1.  .S APCLBEG=$P(X,U,2)
  1.  .S APCLEND=$P(X,U,3)
  1.  .S APCLMRNO=$P(X,U,4)
  1.  .S APCLMRSF=$P(X,U,5)
  1.  .D WRT
  1.  .S APCLCTR=APCLCTR+1
  1.  .I $Y>(IOSL-5) D  I '$D(DUOUT) D HEADING
  1.  ..I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR
  1.  ;
  1.  I '$D(DUOUT) W !!,"Total: ",APCLCTR
  1.  Q
  1.  ;
  1. MRBLOOP ;EP
  1.  I $E(IOST)="C" W !!,"Please be patient.  This may take a few minutes.",!! H 6
  1.  S APCLINAM="Medicare Part B"
  1.  K ^TMP($J,"APCLPYR")
  1.  S APCLPAGE=0
  1.  ;
  1.  D HEADING
  1.  ;
  1.  S APCLDFN=0
  1.  F  S APCLDFN=$O(^AUPNMCR(APCLDFN)) Q:'APCLDFN  D  Q:$D(DUOUT)
  1.  .;Check if Patient is registered here
  1.  .S Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
  1.  .I Y="" Q
  1.  .I Y<1 Q
  1.  .;
  1.  .I APCLSORT="NAME" S APCLSRT=$P(^DPT(APCLDFN,0),U)_U_APCLDFN
  1.  .I APCLSORT="HRNO" S APCLSRT=Y
  1.  .;
  1.  .;-->  Check for Other Insurance if user picked this option
  1.  .I APCLOTH=1 D  Q:APCLICTR>1
  1.  ..S APCLICTR=0
  1.  ..I +$O(^AUPNMCR("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
  1.  ..I +$O(^AUPNMCD("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
  1.  ..I +$O(^AUPNRRE("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
  1.  ..S X=0
  1.  ..F  S X=$O(^AUPNPRVT("B",APCLDFN,11,X)) Q:'X  S APCLICTR=APCLICTR+1
  1.  .;
  1.  .S APCLCTR=0
  1.  .S APCLIEN=0
  1.  .S APCLFLAG=0
  1.  .F  S APCLIEN=$O(^AUPNMCR(APCLDFN,11,APCLIEN)) Q:'APCLIEN  D
  1.  ..S APCLCTR=APCLCTR+1
  1.  ..I $P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="B" Q
  1.  ..S APCLFLAG=APCLIEN
  1.  ..S APCLBEG=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
  1.  ..S APCLEND=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
  1.  ..;--> There is no Beg Date 
  1.  ..I APCLACT,APCLBEG="" S APCLFLAG=0
  1.  ..;-->  User wants to restrict to beg elig dates after beg date
  1.  ..I APCLACT=2,APCLBEG<APCLBDAT S APCLFLAG=0
  1.  ..;--> Beg Date is earlier than selected end date 
  1.  ..I APCLACT,APCLEDAT>0,APCLBEG>APCLEDAT S APCLFLAG=0
  1.  ..;--> End date is before selected begin date 
  1.  ..I APCLACT,APCLEND>0,APCLEND<APCLBDAT S APCLFLAG=0
  1.  .I APCLFLAG D
  1.  ..;S APCLMRNO=$P(^AUPNMCR(APCLDFN,0),U,3)
  1.  ..S APCLMRNO=$$GETMCR^AGUTL(APCLDFN)  ;IHS/CMI/LAB NMCI PATCH 21
  1.  ..S APCLMRSF=""
  1.  ..S X=$P(^AUPNMCR(APCLDFN,0),U,4)
  1.  ..I X S APCLMRSF=$G(^AUTTMCS(X,0))
  1.  ..I APCLOTH,APCLCTR=1 D STORE
  1.  ..I APCLOTH=0 D STORE
  1.  ;
  1.  S APCLCTR=0
  1.  S APCLSRT=""
  1.  F  S APCLSRT=$O(^TMP($J,"APCLPYR",APCLSRT)) Q:APCLSRT=""  D  Q:$D(DUOUT)
  1.  .S X=^TMP($J,"APCLPYR",APCLSRT)
  1.  .S APCLDFN=$P(X,U)
  1.  .S APCLBEG=$P(X,U,2)
  1.  .S APCLEND=$P(X,U,3)
  1.  .S APCLMRNO=$P(X,U,4)
  1.  .S APCLMRSF=$P(X,U,5)
  1.  .D WRT
  1.  .S APCLCTR=APCLCTR+1
  1.  .I $Y>(IOSL-5) D  I '$D(DUOUT) D HEADING
  1.  ..I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR
  1.  ;
  1.  I '$D(DUOUT) W !!,"Total: ",APCLCTR
  1.  Q
  1.  ;
  1. MRDLOOP ;EP
  1.  I $E(IOST)="C" W !!,"Please be patient.  This may take a few minutes.",!! H 6
  1.  S APCLINAM="Medicare Part D"
  1.  K ^TMP($J,"APCLPYR")
  1.  S APCLPAGE=0
  1.  ;
  1.  D HEADING
  1.  ;
  1.  S APCLDFN=0
  1.  F  S APCLDFN=$O(^AUPNMCR(APCLDFN)) Q:'APCLDFN  D  Q:$D(DUOUT)
  1.  .;Check if Patient is registered here
  1.  .S Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
  1.  .I Y="" Q
  1.  .I Y<1 Q
  1.  .;
  1.  .I APCLSORT="NAME" S APCLSRT=$P(^DPT(APCLDFN,0),U)_U_APCLDFN
  1.  .I APCLSORT="HRNO" S APCLSRT=Y
  1.  .;
  1.  .;-->  Check for Other Insurance if user picked this option
  1.  .I APCLOTH=1 D  Q:APCLICTR>1
  1.  ..S APCLICTR=0
  1.  ..I +$O(^AUPNMCR("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
  1.  ..I +$O(^AUPNMCD("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
  1.  ..I +$O(^AUPNRRE("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
  1.  ..S X=0
  1.  ..F  S X=$O(^AUPNPRVT("B",APCLDFN,11,X)) Q:'X  S APCLICTR=APCLICTR+1
  1.  .;
  1.  .S APCLCTR=0
  1.  .S APCLIEN=0
  1.  .S APCLFLAG=0
  1.  .F  S APCLIEN=$O(^AUPNMCR(APCLDFN,11,APCLIEN)) Q:'APCLIEN  D
  1.  ..S APCLCTR=APCLCTR+1
  1.  ..I $P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="D" Q
  1.  ..S APCLFLAG=APCLIEN
  1.  ..S APCLBEG=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
  1.  ..S APCLEND=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
  1.  ..;--> There is no Beg Date 
  1.  ..I APCLACT,APCLBEG="" S APCLFLAG=0
  1.  ..;-->  User wants to restrict to beg elig dates after beg date
  1.  ..I APCLACT=2,APCLBEG<APCLBDAT S APCLFLAG=0
  1.  ..;--> Beg Date is earlier than selected end date 
  1.  ..I APCLACT,APCLEDAT>0,APCLBEG>APCLEDAT S APCLFLAG=0
  1.  ..;--> End date is before selected begin date 
  1.  ..I APCLACT,APCLEND>0,APCLEND<APCLBDAT S APCLFLAG=0
  1.  .I APCLFLAG D
  1.  ..;S APCLMRNO=$P(^AUPNMCR(APCLDFN,0),U,3)
  1.  ..S APCLMRNO=$$GETMCR^AGUTL(APCLDFN)  ;IHS/CMI/LAB NMCI PATCH 21
  1.  ..S APCLMRSF=""
  1.  ..S X=$P(^AUPNMCR(APCLDFN,0),U,4)
  1.  ..I X S APCLMRSF=$G(^AUTTMCS(X,0))
  1.  ..I APCLOTH,APCLCTR=1 D STORE
  1.  ..I APCLOTH=0 D STORE
  1.  ;
  1.  S APCLCTR=0
  1.  S APCLSRT=""
  1.  F  S APCLSRT=$O(^TMP($J,"APCLPYR",APCLSRT)) Q:APCLSRT=""  D  Q:$D(DUOUT)
  1.  .S X=^TMP($J,"APCLPYR",APCLSRT)
  1.  .S APCLDFN=$P(X,U)
  1.  .S APCLBEG=$P(X,U,2)
  1.  .S APCLEND=$P(X,U,3)
  1.  .S APCLMRNO=$P(X,U,4)
  1.  .S APCLMRSF=$P(X,U,5)
  1.  .D WRT
  1.  .S APCLCTR=APCLCTR+1
  1.  .I $Y>(IOSL-5) D  I '$D(DUOUT) D HEADING
  1.  ..I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR
  1.  ;
  1.  I '$D(DUOUT) W !!,"Total: ",APCLCTR
  1.  Q
  1.  ;
  1. STORE ;
  1.  S ^TMP($J,"APCLPYR",APCLSRT)=APCLDFN_U_APCLBEG_U_APCLEND_U_APCLMRNO_U_APCLMRSF
  1.  Q
  1.  ;
  1. WRT ;
  1.  W $P(^DPT(APCLDFN,0),U)
  1.  W ?32,$J($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
  1.  W ?41,APCLMRNO
  1.  W ?53,APCLMRSF
  1.  I APCLALL=0 D  Q
  1.  .W ?57,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
  1.  .I APCLEND W ?67,$E(APCLEND,4,5),"/",$E(APCLEND,6,7),"/",$E(APCLEND,2,3)
  1.  .W !
  1.  S APCLIEN=0
  1.  F  S APCLIEN=$O(^AUPNMCR(APCLDFN,11,APCLIEN)) Q:'APCLIEN  D
  1.  .S APCLBEG=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
  1.  .I APCLACT=2,APCLBEG<APCLBDAT Q
  1.  .S APCLEND=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
  1.  .I APCLTYP="MRA",$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="A" Q
  1.  .I APCLTYP="MRB",$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="B" Q
  1.  .I APCLTYP="MRD",$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="D" Q
  1.  .W ?57,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
  1.  .I APCLEND W ?67,$E(APCLEND,4,5),"/",$E(APCLEND,6,7),"/",$E(APCLEND,2,3)
  1.  .W !
  1.  Q
  1.  ;
  1. HEADING ;
  1.  D ^XBCLS
  1.  W !
  1.  S X=DT
  1.  W $E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)
  1.  S X=$P($G(^DIC(4,APCLFAC,0)),U)
  1.  W ?((IOM-$L(X))/2),X
  1.  S APCLPAGE=APCLPAGE+1
  1.  W ?70,"Page ",APCLPAGE
  1.  W !
  1.  ;
  1.  S X="Patient List for "_APCLINAM
  1.  W ?((IOM-$L(X))/2),X,!
  1.  ;
  1.  S X=""
  1.  I APCLOTH=1 S X=X_"Having only this insurance"
  1.  I X]"" W ?((IOM-$L(X))/2),X,!
  1.  ;
  1.  S X=""
  1.  I APCLACT=0 S X=X_"With any eligibility dates"
  1.  I APCLACT D
  1.  .S X=X_"With eligibility "
  1.  .I $G(APCLEDAT)=$G(APCLBDAT) S X=X_"as of "
  1.  .I $G(APCLEDAT)'=$G(APCLBDAT) S X=X_"from "
  1.  .S X=X_$E(APCLBDAT,4,5)_"/"_$E(APCLBDAT,6,7)_"/"_$E(APCLBDAT,2,3)
  1.  .I $G(APCLEDAT)=$G(APCLBDAT) Q
  1.  .I $G(APCLEDAT)="" Q
  1.  .S X=X_" to "
  1.  .S X=X_$E(APCLEDAT,4,5)_"/"_$E(APCLEDAT,6,7)_"/"_$E(APCLEDAT,2,3)
  1.  I X]"" W ?((IOM-$L(X))/2),X,!
  1.  ;
  1.  W !
  1.  ;
  1.  W "Patient Name",?33,"HRNO",?43,"MCR #",?52,"SUF",?59,"Begin",?69,"End"
  1.  W !
  1.  ;
  1.  W "------------",?32,"------",?41,"---------",?52,"---",?57,"--------",?67,"--------"
  1.  W !
  1.  Q