AUPN99P7 ;IHS/CMI/LAB,GTH,EFG,SDR - AUPN 99.1 PATCH 7 ; [ 05/09/2003 7:58 AM ]
;;99.1;IHS DICTIONARIES (PATIENT);**7,9,10**;JUN 13, 2003;Build 9
;
; IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
;
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q
;
S X=$P(^VA(200,DUZ,0),U)
W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_".",IOM)
;
NEW AUPNQUIT
S AUPNQUIT=0
I '$$VCHK("AUPN","99.1",2) S AUPNQUIT=2
I '$$VCHK("DI","21.0",2) S AUPNQUIT=2
I '$$VCHK("XU","8.0",2) S AUPNQUIT=2
S X=$$VERSION^XPDUTL("AUT")
W !,$$CJ^XLFSTR("Need at least AUT 98.1.....AUT "_X_" Present",IOM)
I X<98.1,+X'=1.1 S AUPNQUIT=2
I '$$INSTALLD("AUT*98.1*7") S AUPNQUIT=2
;
NEW DA,DIC
S X="AUPN",DIC="^DIC(9.4,",DIC(0)="",D="C"
D IX^DIC
I Y<0,$D(^DIC(9.4,"C","AUPN")) D Q
. W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUPN"" prefix.",IOM)
. W !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)
. W !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7
. D SORRY(2)
. I $$DIR^XBDIR("E")
.Q
W !,$$CJ^XLFSTR("No 'AUPN' dups in PACKAGE file",IOM)
;
I AUPNQUIT D SORRY(AUPNQUIT) Q
;
I $G(XPDENV)=1 D
. ; The following line prevents the "Disable Options..." and "Move
. ; Routines..." questions from being asked during the install.
. S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
.Q
;
W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
;
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
Q
;
SORRY(X) ;
KILL DIFQ
S XPDQUIT=X
W:'$D(ZTQUEUED) *7,!,$$CJ^XLFSTR("Sorry....",IOM),$$DIR^XBDIR("E","Press RETURN")
Q
;
VCHK(AUPNPRE,AUPNVER,AUPNQUIT) ; Check versions needed.
;
NEW AUPNV
S AUPNV=$$VERSION^XPDUTL(AUPNPRE)
W !,$$CJ^XLFSTR("Need at least "_AUPNPRE_" v "_AUPNVER_"....."_AUPNPRE_" v "_AUPNV_" Present",IOM)
I AUPNV<AUPNVER W *7,!,$$CJ^XLFSTR("Sorry....",IOM) Q 0
Q 1
;
PRE ;EP - From KIDS.
D BMES^XPDUTL("Beginning Pre-install routine (PRE^AUPN99P7).")
I '$$INSTALLD("AUPN*99.1*6") D I 1
. D BMES^XPDUTL("AUPN*99.1*6 NOT installed. Deleting dd fields .")
. NEW DIK
. S DIK="^DD(9000010.24,",DA=.01,DA(1)=9000010.24 D ^DIK
. S DIK="^DD(9000010.24,",DA=.04,DA(1)=9000010.24 D ^DIK
. S DIK="^DD(9000010.34,",DA=.01,DA(1)=9000010.34 D ^DIK
.Q
E D BMES^XPDUTL("AUPN*99.1*6 is installed. No dd fields deleted.")
;
D BMES^XPDUTL("Pre-install routine is complete.")
Q
;
POST ;EP - From KIDS.
D BMES^XPDUTL("Beginning post-install routine (POST^AUPN99P7).")
;
D QUERPT
;
I '$$INSTALLD("AUPN*99.1*5") D I 1
. D BMES^XPDUTL("AUPN*99.1*5 not installed."),MES^XPDUTL(" Indexing AE x-ref on Medicaid Eligible...")
. D POST^AUPN99P5
. D MES^XPDUTL("X-ref complete.")
.Q
E D BMES^XPDUTL("AUPN*99.1*5 is installed. No action necessary.")
;
D MAIL
;
D BMES^XPDUTL("Post-install routine is complete.")
Q
;
MAIL ; Send install mail message.
D BMES^XPDUTL("Delivering AUPN*99.1*7 install message to select users...")
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("AUPN99P7MS",$J)
S ^TMP("AUPN99P7MS",$J,1)=" --- AUPN v 99.1, Patch 7, has been installed into this uci ---"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% S ^TMP("AUPN99P7MS",$J,(%+1))=" "_^(%,0)
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AUPN99P7MS"",$J,",XMY(1)="",XMY(DUZ)=""
F %="AGZMENU","APCDZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("AUPN99P7MS",$J)
Q
;
SINGLE(K) ; Get holders of a single key K.
NEW Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
;
INSTALLD(AUPNSTAL) ;EP - Determine if patch AUPNSTAL was installed, where
; AUPNSTAL is the name of the INSTALL. E.g "AG*6.0*10".
;
NEW AUPNY,DIC,X,Y
S X=$P(AUPNSTAL,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",22,",X=$P(AUPNSTAL,"*",2)
D ^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(AUPNSTAL,"*",3)
D ^DIC
S AUPNY=Y
D MES^XPDUTL($$CJ^XLFSTR("Patch """_AUPNSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
Q $S(AUPNY<1:0,1:1)
;
QUERPT ;
D BMES^XPDUTL("Q'ing one-time report on begin/end dates in Insurance Eligible files...")
;
S ZTRTN="ELIGDATS^AUPN99P7",ZTDESC="Insurance Eligibility Dates.",ZTDTH=$H,ZTIO="",ZTSAVE("DUZ")=""
D ^%ZTLOAD
I '$D(ZTSK) D BMES^XPDUTL("ERROR**: Q to TaskMan failed (?).") Q
D BMES^XPDUTL("Q'd to Task '"_ZTSK_"'.")
Q
;
ELIGDATS ;EP - From TaskMan or Programmer mode.
; One-time report on Insurance Eligibility records whose Ending date
; preceeds the begin date.
;
NEW XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("AUPN991P7",$J)
D DATES
S XMSUB="Insurance Eligibility Dates.",XMDUZ=$G(DUZ,.5),XMTEXT="^TMP(""AUPN991P7"",$J,",XMY(1)="",XMY(DUZ)=""
F %="XUMGR","XUPROGMODE","AGZMENU","ABMDZ ELIGIBILITY EDIT" D SINGLE(%)
NEW DIFROM
D ^XMD
KILL ^TMP("AUPN991P7",$J)
I $D(ZTQUEUED) S ZTREQ="@" Q
W !,"The results are in your MailMan 'IN' basket."
Q
;
DATES ;
;;This is a one time report, released in patch AUPN*99.1*7.
;;
;;However, if you need to rerun the report, D QUERPT^AUPN99P7,
;;is the command from programmer mode.
;;
;;You are receiving this message b/c of the particular security
;;keys that you hold. If you are not an appropriate person at
;;your facility to correct any coverages that are listed, below,
;;please ensure the appropriate person receives this report.
;;
;;This report lists Insurance elgibility coverages whose coverage
;;dates include an ending date that -PRECEEDS- the begin date.
;;Coverages with dates in that condition will result in the
;;associated beginning date not being found by any Third Party
;;Billing application.
;;
;;Insurance coverages in this condition were found during routine
;;analysis of the 9.5 million insurance eligibility records received
;;during the NPIRS reload of 2001. That analysis indicated about
;;12,000 (1/10th of 1 percent) of the records had an ending date
;;that preceeded the begin date.
;;
;;Patch AUPN*99.1*7 will prevent this condition from being entered
;;for MEDICARE, MEDICAID, and RAILROAD insurance elgibiltiy dates
;;by placing a check on the ending date during data entry. However,
;;PRIVATE INSURANCE is more complicated in its computation, and an
;;associated patch will be released thru Patient Registration (AG).
;;
;;end
;
F %=1:1 S X=$P($T(DATES+%),";",3) Q:X="end" D RSLT(X)
D HDR,MCR,HDR,MCD,HDR,RRE,HDR,PVT
Q
;
HDR ;
D RSLT("-------------------------------------------------------------")
D RSLT(""),RSLT("")
D RSLT("TYPE BEGIN DATE END DATE TYPE ASUFAC/HRN")
D RSLT("-------------------------------------------------------------")
Q
;
MCR ;
NEW A,D,I,P
F P=0:0 S P=$O(^AUPNMCR(P)) Q:'P D
. F I=0:0 S I=$O(^AUPNMCR(P,11,I)) Q:'I D
.. Q:'$P(^AUPNMCR(P,11,I,0),U,2) S D=^(0)
.. Q:'($P(D,U,2)<$P(D,U,1))
.. S A=$$ASU(P),D=$$FMTE(D)
.. D RSLT("MEDICARE "_$P(D,U,1)_" "_$P(D,U,2)_" "_$$LJ^XLFSTR($P(D,U,3),8)_$P(A,U))
.. F %=2:1 Q:'$L($P(A,U,%)) D RSLT($J("",48)_$P(A,U,%))
..Q
.Q
Q
;
MCD ;
NEW A,I,J,Y,P
F P=0:0 S P=$O(^AUPNMCD(P)) Q:'P D
. F I=0:0 S I=$O(^AUPNMCD(P,11,I)) Q:'I D
.. Q:'$P(^AUPNMCD(P,11,I,0),U,2) S D=^(0)
.. Q:'($P(D,U,2)<$P(D,U,1))
.. S A=$$ASU($P(^AUPNMCD(P,0),U)),D=$$FMTE(D)
.. D RSLT("MEDICAID "_$P(D,U,1)_" "_$P(D,U,2)_" "_$$LJ^XLFSTR($P(D,U,3),8)_$P(A,U))
.. F %=2:1 Q:'$L($P(A,U,%)) D RSLT($J("",48)_$P(A,U,%))
..Q
.Q
Q
;
RRE ;
NEW A,I,P
F P=0:0 S P=$O(^AUPNRRE(P)) Q:'P D
. F I=0:0 S I=$O(^AUPNRRE(P,11,I)) Q:'I D
.. Q:'$P(^AUPNRRE(P,11,I,0),U,2) S D=^(0)
.. Q:'($P(D,U,2)<$P(D,U,1))
.. S A=$$ASU(P),D=$$FMTE(D)
.. D RSLT("RAILROAD "_$P(D,U,1)_" "_$P(D,U,2)_" "_$$LJ^XLFSTR($P(D,U,3),8)_$P(A,U))
.. F %=2:1 Q:'$L($P(A,U,%)) D RSLT($J("",48)_$P(A,U,%))
..Q
.Q
Q
;
PVT ;
NEW A,I,J,Y,P
F P=0:0 S P=$O(^AUPNPRVT(P)) Q:'P D
. F I=0:0 S I=$O(^AUPNPRVT(P,11,I)) Q:'I D
.. Q:'$P(^AUPNPRVT(P,11,I,0),U,7) S D=^(0)
.. Q:'($P(D,U,7)<$P(D,U,6))
.. S A=$$ASU($P(^AUPNPRVT(P,0),U)),D=$P(D,U,6)_U_$P(D,U,7)_U_$P(D,U,3),D=$$FMTE(D)
.. D RSLT("PRIVATE "_$P(D,U,1)_" "_$P(D,U,2)_" "_$P(A,U))
.. F %=2:1 Q:'$L($P(A,U,%)) D RSLT($J("",48)_$P(A,U,%))
..Q
.Q
Q
;
ASU(P) ;
NEW I,X
S X=""
F I=0:0 S I=$O(^AUPNPAT(P,41,I)) Q:'I S X=X_$P(^AUTTLOC(I,0),U,10)_"/"_$J($P(^AUPNPAT(P,41,I,0),U,2),6)_U
Q X
;
RSLT(%) S ^(0)=$G(^TMP("AUPN991P7",$J,0))+1,^(^(0))=%
Q
;
FMTE(D) ;
NEW A,I,J,Y,P,X
Q $$FMTE^XLFDT($P(D,U))_U_$$FMTE^XLFDT($P(D,U,2))_U_$P(D,U,3)
;
AUPN99P7 ;IHS/CMI/LAB,GTH,EFG,SDR - AUPN 99.1 PATCH 7 ; [ 05/09/2003 7:58 AM ]
+1 ;;99.1;IHS DICTIONARIES (PATIENT);**7,9,10**;JUN 13, 2003;Build 9
+2 ;
+3 ; IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
+4 ;
+5 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
DO SORRY(2)
QUIT
+6 ;
+7 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
DO SORRY(2)
QUIT
+8 ;
+9 SET X=$PIECE(^VA(200,DUZ,0),U)
+10 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+11 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_" Patch "_$PIECE($TEXT(+2),";",5)_".",IOM)
+12 ;
+13 NEW AUPNQUIT
+14 SET AUPNQUIT=0
+15 IF '$$VCHK("AUPN","99.1",2)
SET AUPNQUIT=2
+16 IF '$$VCHK("DI","21.0",2)
SET AUPNQUIT=2
+17 IF '$$VCHK("XU","8.0",2)
SET AUPNQUIT=2
+18 SET X=$$VERSION^XPDUTL("AUT")
+19 WRITE !,$$CJ^XLFSTR("Need at least AUT 98.1.....AUT "_X_" Present",IOM)
+20 IF X<98.1
IF +X'=1.1
SET AUPNQUIT=2
+21 IF '$$INSTALLD("AUT*98.1*7")
SET AUPNQUIT=2
+22 ;
+23 NEW DA,DIC
+24 SET X="AUPN"
SET DIC="^DIC(9.4,"
SET DIC(0)=""
SET D="C"
+25 DO IX^DIC
+26 IF Y<0
IF $DATA(^DIC(9.4,"C","AUPN"))
Begin DoDot:1
+27 WRITE !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUPN"" prefix.",IOM)
+28 WRITE !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)
+29 WRITE !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7
+30 DO SORRY(2)
+31 IF $$DIR^XBDIR("E")
+32 QUIT
End DoDot:1
QUIT
+33 WRITE !,$$CJ^XLFSTR("No 'AUPN' dups in PACKAGE file",IOM)
+34 ;
+35 IF AUPNQUIT
DO SORRY(AUPNQUIT)
QUIT
+36 ;
+37 IF $GET(XPDENV)=1
Begin DoDot:1
+38 ; The following line prevents the "Disable Options..." and "Move
+39 ; Routines..." questions from being asked during the install.
+40 SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+41 QUIT
End DoDot:1
+42 ;
+43 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
+44 ;
+45 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
QUIT
+46 QUIT
+47 ;
SORRY(X) ;
+1 KILL DIFQ
+2 SET XPDQUIT=X
+3 IF '$DATA(ZTQUEUED)
WRITE *7,!,$$CJ^XLFSTR("Sorry....",IOM),$$DIR^XBDIR("E","Press RETURN")
+4 QUIT
+5 ;
VCHK(AUPNPRE,AUPNVER,AUPNQUIT) ; Check versions needed.
+1 ;
+2 NEW AUPNV
+3 SET AUPNV=$$VERSION^XPDUTL(AUPNPRE)
+4 WRITE !,$$CJ^XLFSTR("Need at least "_AUPNPRE_" v "_AUPNVER_"....."_AUPNPRE_" v "_AUPNV_" Present",IOM)
+5 IF AUPNV<AUPNVER
WRITE *7,!,$$CJ^XLFSTR("Sorry....",IOM)
QUIT 0
+6 QUIT 1
+7 ;
PRE ;EP - From KIDS.
+1 DO BMES^XPDUTL("Beginning Pre-install routine (PRE^AUPN99P7).")
+2 IF '$$INSTALLD("AUPN*99.1*6")
Begin DoDot:1
+3 DO BMES^XPDUTL("AUPN*99.1*6 NOT installed. Deleting dd fields .")
+4 NEW DIK
+5 SET DIK="^DD(9000010.24,"
SET DA=.01
SET DA(1)=9000010.24
DO ^DIK
+6 SET DIK="^DD(9000010.24,"
SET DA=.04
SET DA(1)=9000010.24
DO ^DIK
+7 SET DIK="^DD(9000010.34,"
SET DA=.01
SET DA(1)=9000010.34
DO ^DIK
+8 QUIT
End DoDot:1
IF 1
+9 IF '$TEST
DO BMES^XPDUTL("AUPN*99.1*6 is installed. No dd fields deleted.")
+10 ;
+11 DO BMES^XPDUTL("Pre-install routine is complete.")
+12 QUIT
+13 ;
POST ;EP - From KIDS.
+1 DO BMES^XPDUTL("Beginning post-install routine (POST^AUPN99P7).")
+2 ;
+3 DO QUERPT
+4 ;
+5 IF '$$INSTALLD("AUPN*99.1*5")
Begin DoDot:1
+6 DO BMES^XPDUTL("AUPN*99.1*5 not installed.")
DO MES^XPDUTL(" Indexing AE x-ref on Medicaid Eligible...")
+7 DO POST^AUPN99P5
+8 DO MES^XPDUTL("X-ref complete.")
+9 QUIT
End DoDot:1
IF 1
+10 IF '$TEST
DO BMES^XPDUTL("AUPN*99.1*5 is installed. No action necessary.")
+11 ;
+12 DO MAIL
+13 ;
+14 DO BMES^XPDUTL("Post-install routine is complete.")
+15 QUIT
+16 ;
MAIL ; Send install mail message.
+1 DO BMES^XPDUTL("Delivering AUPN*99.1*7 install message to select users...")
+2 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+3 KILL ^TMP("AUPN99P7MS",$JOB)
+4 SET ^TMP("AUPN99P7MS",$JOB,1)=" --- AUPN v 99.1, Patch 7, has been installed into this uci ---"
+5 SET %=0
+6 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
SET ^TMP("AUPN99P7MS",$JOB,(%+1))=" "_^(%,0)
+7 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""AUPN99P7MS"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+8 FOR %="AGZMENU","APCDZMENU","XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+9 DO ^XMD
+10 KILL ^TMP("AUPN99P7MS",$JOB)
+11 QUIT
+12 ;
SINGLE(K) ; Get holders of a single key K.
+1 NEW Y
+2 SET Y=0
+3 IF '$DATA(^XUSEC(K))
QUIT
+4 FOR
SET Y=$ORDER(^XUSEC(K,Y))
IF 'Y
QUIT
SET XMY(Y)=""
+5 QUIT
+6 ;
INSTALLD(AUPNSTAL) ;EP - Determine if patch AUPNSTAL was installed, where
+1 ; AUPNSTAL is the name of the INSTALL. E.g "AG*6.0*10".
+2 ;
+3 NEW AUPNY,DIC,X,Y
+4 SET X=$PIECE(AUPNSTAL,"*",1)
+5 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+6 DO IX^DIC
+7 IF Y<1
QUIT 0
+8 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(AUPNSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(AUPNSTAL,"*",3)
+12 DO ^DIC
+13 SET AUPNY=Y
+14 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_AUPNSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" installed.",IOM))
+15 QUIT $SELECT(AUPNY<1:0,1:1)
+16 ;
QUERPT ;
+1 DO BMES^XPDUTL("Q'ing one-time report on begin/end dates in Insurance Eligible files...")
+2 ;
+3 SET ZTRTN="ELIGDATS^AUPN99P7"
SET ZTDESC="Insurance Eligibility Dates."
SET ZTDTH=$HOROLOG
SET ZTIO=""
SET ZTSAVE("DUZ")=""
+4 DO ^%ZTLOAD
+5 IF '$DATA(ZTSK)
DO BMES^XPDUTL("ERROR**: Q to TaskMan failed (?).")
QUIT
+6 DO BMES^XPDUTL("Q'd to Task '"_ZTSK_"'.")
+7 QUIT
+8 ;
ELIGDATS ;EP - From TaskMan or Programmer mode.
+1 ; One-time report on Insurance Eligibility records whose Ending date
+2 ; preceeds the begin date.
+3 ;
+4 NEW XMSUB,XMDUZ,XMTEXT,XMY
+5 KILL ^TMP("AUPN991P7",$JOB)
+6 DO DATES
+7 SET XMSUB="Insurance Eligibility Dates."
SET XMDUZ=$GET(DUZ,.5)
SET XMTEXT="^TMP(""AUPN991P7"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+8 FOR %="XUMGR","XUPROGMODE","AGZMENU","ABMDZ ELIGIBILITY EDIT"
DO SINGLE(%)
+9 NEW DIFROM
+10 DO ^XMD
+11 KILL ^TMP("AUPN991P7",$JOB)
+12 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+13 WRITE !,"The results are in your MailMan 'IN' basket."
+14 QUIT
+15 ;
DATES ;
+1 ;;This is a one time report, released in patch AUPN*99.1*7.
+2 ;;
+3 ;;However, if you need to rerun the report, D QUERPT^AUPN99P7,
+4 ;;is the command from programmer mode.
+5 ;;
+6 ;;You are receiving this message b/c of the particular security
+7 ;;keys that you hold. If you are not an appropriate person at
+8 ;;your facility to correct any coverages that are listed, below,
+9 ;;please ensure the appropriate person receives this report.
+10 ;;
+11 ;;This report lists Insurance elgibility coverages whose coverage
+12 ;;dates include an ending date that -PRECEEDS- the begin date.
+13 ;;Coverages with dates in that condition will result in the
+14 ;;associated beginning date not being found by any Third Party
+15 ;;Billing application.
+16 ;;
+17 ;;Insurance coverages in this condition were found during routine
+18 ;;analysis of the 9.5 million insurance eligibility records received
+19 ;;during the NPIRS reload of 2001. That analysis indicated about
+20 ;;12,000 (1/10th of 1 percent) of the records had an ending date
+21 ;;that preceeded the begin date.
+22 ;;
+23 ;;Patch AUPN*99.1*7 will prevent this condition from being entered
+24 ;;for MEDICARE, MEDICAID, and RAILROAD insurance elgibiltiy dates
+25 ;;by placing a check on the ending date during data entry. However,
+26 ;;PRIVATE INSURANCE is more complicated in its computation, and an
+27 ;;associated patch will be released thru Patient Registration (AG).
+28 ;;
+29 ;;end
+30 ;
+31 FOR %=1:1
SET X=$PIECE($TEXT(DATES+%),";",3)
IF X="end"
QUIT
DO RSLT(X)
+32 DO HDR
DO MCR
DO HDR
DO MCD
DO HDR
DO RRE
DO HDR
DO PVT
+33 QUIT
+34 ;
HDR ;
+1 DO RSLT("-------------------------------------------------------------")
+2 DO RSLT("")
DO RSLT("")
+3 DO RSLT("TYPE BEGIN DATE END DATE TYPE ASUFAC/HRN")
+4 DO RSLT("-------------------------------------------------------------")
+5 QUIT
+6 ;
MCR ;
+1 NEW A,D,I,P
+2 FOR P=0:0
SET P=$ORDER(^AUPNMCR(P))
IF 'P
QUIT
Begin DoDot:1
+3 FOR I=0:0
SET I=$ORDER(^AUPNMCR(P,11,I))
IF 'I
QUIT
Begin DoDot:2
+4 IF '$PIECE(^AUPNMCR(P,11,I,0),U,2)
QUIT
SET D=^(0)
+5 IF '($PIECE(D,U,2)<$PIECE(D,U,1))
QUIT
+6 SET A=$$ASU(P)
SET D=$$FMTE(D)
+7 DO RSLT("MEDICARE "_$PIECE(D,U,1)_" "_$PIECE(D,U,2)_" "_$$LJ^XLFSTR($PIECE(D,U,3),8)_$PIECE(A,U))
+8 FOR %=2:1
IF '$LENGTH($PIECE(A,U,%))
QUIT
DO RSLT($JUSTIFY("",48)_$PIECE(A,U,%))
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
MCD ;
+1 NEW A,I,J,Y,P
+2 FOR P=0:0
SET P=$ORDER(^AUPNMCD(P))
IF 'P
QUIT
Begin DoDot:1
+3 FOR I=0:0
SET I=$ORDER(^AUPNMCD(P,11,I))
IF 'I
QUIT
Begin DoDot:2
+4 IF '$PIECE(^AUPNMCD(P,11,I,0),U,2)
QUIT
SET D=^(0)
+5 IF '($PIECE(D,U,2)<$PIECE(D,U,1))
QUIT
+6 SET A=$$ASU($PIECE(^AUPNMCD(P,0),U))
SET D=$$FMTE(D)
+7 DO RSLT("MEDICAID "_$PIECE(D,U,1)_" "_$PIECE(D,U,2)_" "_$$LJ^XLFSTR($PIECE(D,U,3),8)_$PIECE(A,U))
+8 FOR %=2:1
IF '$LENGTH($PIECE(A,U,%))
QUIT
DO RSLT($JUSTIFY("",48)_$PIECE(A,U,%))
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
RRE ;
+1 NEW A,I,P
+2 FOR P=0:0
SET P=$ORDER(^AUPNRRE(P))
IF 'P
QUIT
Begin DoDot:1
+3 FOR I=0:0
SET I=$ORDER(^AUPNRRE(P,11,I))
IF 'I
QUIT
Begin DoDot:2
+4 IF '$PIECE(^AUPNRRE(P,11,I,0),U,2)
QUIT
SET D=^(0)
+5 IF '($PIECE(D,U,2)<$PIECE(D,U,1))
QUIT
+6 SET A=$$ASU(P)
SET D=$$FMTE(D)
+7 DO RSLT("RAILROAD "_$PIECE(D,U,1)_" "_$PIECE(D,U,2)_" "_$$LJ^XLFSTR($PIECE(D,U,3),8)_$PIECE(A,U))
+8 FOR %=2:1
IF '$LENGTH($PIECE(A,U,%))
QUIT
DO RSLT($JUSTIFY("",48)_$PIECE(A,U,%))
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
PVT ;
+1 NEW A,I,J,Y,P
+2 FOR P=0:0
SET P=$ORDER(^AUPNPRVT(P))
IF 'P
QUIT
Begin DoDot:1
+3 FOR I=0:0
SET I=$ORDER(^AUPNPRVT(P,11,I))
IF 'I
QUIT
Begin DoDot:2
+4 IF '$PIECE(^AUPNPRVT(P,11,I,0),U,7)
QUIT
SET D=^(0)
+5 IF '($PIECE(D,U,7)<$PIECE(D,U,6))
QUIT
+6 SET A=$$ASU($PIECE(^AUPNPRVT(P,0),U))
SET D=$PIECE(D,U,6)_U_$PIECE(D,U,7)_U_$PIECE(D,U,3)
SET D=$$FMTE(D)
+7 DO RSLT("PRIVATE "_$PIECE(D,U,1)_" "_$PIECE(D,U,2)_" "_$PIECE(A,U))
+8 FOR %=2:1
IF '$LENGTH($PIECE(A,U,%))
QUIT
DO RSLT($JUSTIFY("",48)_$PIECE(A,U,%))
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
ASU(P) ;
+1 NEW I,X
+2 SET X=""
+3 FOR I=0:0
SET I=$ORDER(^AUPNPAT(P,41,I))
IF 'I
QUIT
SET X=X_$PIECE(^AUTTLOC(I,0),U,10)_"/"_$JUSTIFY($PIECE(^AUPNPAT(P,41,I,0),U,2),6)_U
+4 QUIT X
+5 ;
RSLT(%) SET ^(0)=$GET(^TMP("AUPN991P7",$JOB,0))+1
SET ^(^(0))=%
+1 QUIT
+2 ;
FMTE(D) ;
+1 NEW A,I,J,Y,P,X
+2 QUIT $$FMTE^XLFDT($PIECE(D,U))_U_$$FMTE^XLFDT($PIECE(D,U,2))_U_$PIECE(D,U,3)
+3 ;
