AG71A4 ;IHS/SD/EFG - Patient Registration 7.1 PATCH 4 PRE/POST INSTALL ;
;;7.1;PATIENT REGISTRATION;**2,3,4**;AUG 25,2005
;
Q
PRE ;EP - From KIDS.
;'AG PATIENT REGISTRATION ERROR CODES' FILE
;FILE 9009061.5 IS DINUMED AND HAS IDENTIFIERS. KIDS WILL NOT TRANSFER
;NEW DATA FOR THOSE FIELDS WITHOUT FIRST KILLING THE GLOBAL DATA FIRST.
;ONLY NEED IF CHANGING DATA IN THIS FILE
S IEN="" F S IEN=$O(^AGEDERRS(IEN)) Q:IEN="" K ^AGEDERRS(IEN)
Q
POST ;EP - From KIDS.
D BMES^XPDUTL("Beginning post-install routine (POST^AG71A)."),TS
;
;CONVERT ENTRIES IN .04 IN AUPNPAT TO
;NEW MULTIPLE FIELD 3601 IN AUPNPAT
;DONE ONLY IF PATCH 1 NOT FOUND
I '$$PATCH("AG*7.1*1") D BMES^XPDUTL("Converting 'Release of Information' AUPNPAT field .04 to new multiple field 3601."),TS D ^AGCNVROI
;
D BMES^XPDUTL("Fixing private eligibility with missing Policy Holder .08 field. or missing insurer pointer"),TS
D PRVT
;
D BMES^XPDUTL("Collecting Medicaid eligibility entries with missing State .04 field."),TS
D MCD
;
D BMES^XPDUTL("Fixing Medicare eligibility B cross references."),TS
D MCR
;
D BMES^XPDUTL("Fixing INSURER IENs containing decimal."),TS
D INSURER
;
D BMES^XPDUTL("Fixing Medicare records with missing .01 fields"),TS
D MCR
;
D BMES^XPDUTL("Fixing Rail Road entries with missing .01 field."),TS
D RRE
;
D BMES^XPDUTL("Fixing incomplete Guarantor records."),TS
D GUAR
;
D BMES^XPDUTL("Fixing patient file with dangling D x-ref"),TS
D PAT
;
D BMES^XPDUTL("Fixing Policy Holder fields"),TS
D POLHOLD
;
D BMES^XPDUTL("Add File #2 VA PATIENT address fields as Site Mandatory field in the REGISTRATION PARAMETER file"),TS
D ADDMAN ;ADD MANDATORY ADDRESS FIELDS IN FILE 2 TO REGISTRATION PARAMETER FILE
;
;TAKE CURRENT ADDRESS AND PHONE FOUND IN FILE #2 AND PLACE INTO THE NEW
;HISTORICAL MULTIPLES
D BMES^XPDUTL("Adding VA PATIENT address fields to PREVIOUS ADDRESS FIELD multiple of File #9000001"),TS
;
S X=$$LAST^XPDUTL("IHS PATIENT REGISTRATION","7.1")
;I $P(X,U)<4 D ADDHIST ;DO THIS ONLY ONCE
D ADDHIST ;RESTORE ABOVE LINE WHEN RELEASING.
;
D SETDEF ;SET DEAFULTS IN NEW PARAMETERS
;
I $$INSTALLD^AG71ENV("AG*7.1") D
. D TS,BMES^XPDUTL("Delivering AG*7.1 install message to select users ...")
. D MAIL
. D BMES^XPDUTL("Post-install routine is complete."),TS
;
Q:$$INSTALLD^AG71ENV("AG*7.1")
;
D TS,OPTRES("AGMENU")
;
D TS,BMES^XPDUTL("Delivering AG*7.1 install message to select users...")
;
D MAIL
;
D BMES^XPDUTL("Post-install routine is complete."),TS
Q
MAIL ;Send install mail message.
N DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
K ^TMP("AG71MS",$J)
S ^TMP("AG71MS",$J,1)=" --- AG v 7.1 Patch 4 has been installed into this uci ---"
S ^TMP("AG71MS",$J,2)=" "
S CNT=3
K AGERRLST
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% S ^TMP("AG71MS",$J,(%+CNT))=" "_^(%,0)
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AG71MS"",$J,",XMY(1)="",XMY(DUZ)=""
F %="AGZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
K ^TMP("AG71MS",$J)
Q
SINGLE(K) ;EP - Get holders of a single key K.
N Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
;
OPTRES(AGM) ;
D BMES^XPDUTL("Restoring '"_AGM_"' option to PRE-install configuration...")
NEW AG,AGI
I '$D(^XTMP("AG71",7.2,"OPTSAV",AGM)) D BMES^XPDUTL("FAILED. Option '"_AGM_"' was not previously saved.") Q
S AG=0
F S AG=$O(^XTMP("AG71",7.2,"OPTSAV",AGM,AG)) Q:'AG S AGI=^(AG) I '$$ADD^XPDMENU(AGM,$P(AGI,U),$P(AGI,U,2),$P(AGI,U,3)) D BMES^XPDUTL("....FAILED to re-attach "_$P(AGI,U)_" to "_AGM_".")
Q
TS D MES^XPDUTL($$HTE^XLFDT($H)) Q
MCD ;CLEAR MCD RECORDS MISSING .01 FIELD
;MUST DO DIRECT KILL BECAUSE X-REF NOT THERE. BOMBS ON USE OF ^DIK
K AGERRLST
N HRN,DFN,ST,MCDNUM
S RECNO=0
F S RECNO=$O(^AUPNMCD(RECNO)) Q:'RECNO D
.;IF THE INS. PTR IS MISSING LETS FIX IT SO TPB CLAIMS GENERATOR DOESN'T BLOW UP
.I '$G(^AUPNMCD(RECNO,0))!('$P($G(^AUPNMCD(RECNO,0)),U)) K ^AUPNMCD(RECNO) Q
.I $P($G(^AUPNMCD(RECNO,0)),U,4)="" S DFN=$P($G(^AUPNMCD(RECNO,0)),U),AGERRLST(RECNO)=$P($G(^DPT(DFN,0)),U)_U_$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
Q
RRE ;FIX "B" X-REF ENTRIES WITH NO ZERO RECORD
;MUST DO DIRECT KILL BECAUSE RECORD NOT THERE. BOMBS ON USE OF ^DIK DOESN'T WORK
S RECNO=""
F S RECNO=$O(^AUPNRRE("B",RECNO)) Q:'RECNO D
.I $P($G(^AUPNRRE(RECNO,0)),U)="" K ^AUPNRRE(RECNO),^AUPNRRE("B",RECNO)
S RECNO=0
F S RECNO=$O(^AUPNRRE(RECNO)) Q:'RECNO D
.I $P($G(^AUPNRRE(RECNO,0)),U)="" K ^AUPNRRE(RECNO),^AUPNRRE("B",RECNO)
Q
MCR ;
S RECNO=""
F S RECNO=$O(^AUPNMCR("B",RECNO)) Q:'RECNO D
.I $P($G(^AUPNMCR(RECNO,0)),U)="" K ^AUPNMCR(RECNO),^AUPNMCR("B",RECNO)
S RECNO=0
F S RECNO=$O(^AUPNMCR(RECNO)) Q:'RECNO D
.I $P($G(^AUPNMCR(RECNO,0)),U)="" K ^AUPNMCR(RECNO),^AUPNMCR("B",RECNO)
Q
INSURER ;EP - CAN WE INCLUDE THIS IN AG PATCH 1??
S RECNO=0
F S RECNO=$O(^AUTNINS(RECNO)) Q:'RECNO D
.I RECNO[(".") K ^AUTNINS(RECNO),^AUTNINS("B",RECNO)
S RECNO=""
F S RECNO=$O(^AUTNINS("B",RECNO)) Q:RECNO="" D
.S RECIEN=""
.F S RECIEN=$O(^AUTNINS("B",RECNO,RECIEN)) Q:RECIEN="" D
..Q:$P($G(^AUTNINS(RECIEN,0)),U)'=""
..K DA,DIR,DIE,DIK,DIC,DR
..S DA=RECIEN,DIK="^AUTNINS(" D ^DIK
Q
PAT ;CLEAN UP D X-REF IN PATIENT FILE
S HRN="" F S HRN=$O(^AUPNPAT("D",HRN)) Q:HRN="" D
.S RECNO="" F S RECNO=$O(^AUPNPAT("D",HRN,RECNO)) Q:RECNO="" D
..I '$D(^AUPNPAT(RECNO))!('$D(^DPT(RECNO))) K ^AUPNPAT("D",HRN,RECNO)
Q
PRVT ;CLEAR ANY PRIVATE ELIG RECORDS MISSING INSURER POINTER
;MUST DO DIRECT KILL BECAUSE X-REF NOT THERE. BOMBS ON USE OF ^DIK
S RECNO=0
F S RECNO=$O(^AUPNPRVT(RECNO)) Q:'RECNO D
.S D1=0
.F S D1=$O(^AUPNPRVT(RECNO,11,D1)) Q:'D1 D
..I $P($G(^AUPNPRVT(RECNO,11,D1,0)),U)="" K ^AUPNPRVT(RECNO,11,D1) Q
..I $P($G(^AUPNPRVT(RECNO,11,D1,0)),U,8)="" S DA=D1,DA(1)=RECNO,DIK="^AUPNPRVT("_DA(1)_",11," D ^DIK
..I $O(^AUPNPRVT(RECNO,11,0)) Q
..S DA=RECNO,DIK="^AUPNPRVT(" D ^DIK
S RECNO=0 F S RECNO=$O(^AUPNPRVT("B",RECNO)) Q:RECNO="" D
.S IEN=0 F S IEN=$O(^AUPNPRVT("B",RECNO,IEN)) Q:'IEN D
..I $P($G(^AUPNPRVT(IEN,0)),U)="" K ^AUPNPRVT(IEN),^AUPNPRVT("B",RECNO,IEN)
Q
GUAR ;CLEAR GUARANTOR RECORDS WITH INCOMPETE ENTRIES
N PATPTR
S PATPTR=0
F S PATPTR=$O(^AUPNGUAR(PATPTR)) Q:'PATPTR D GUAR1(PATPTR)
Q
GUAR1(PATPTR) ;EP - DELETE GUARANTOR ENTRIES WITH MISSING GUARANTORS OR DATES
N SUB1,SUB11,REDO
REDO ;
S SUB1=$O(^AUPNGUAR(PATPTR,1,0))
I 'SUB1 D Q ;NO GUARANTORS FOUND AT ALL
.K DIE,DIK,DA,DIC S DIK="^AUPNGUAR(",DA=PATPTR D ^DIK
;FOR EACH GUARANTOR ARE THERE EFFECTIVE DATES?
S (SUB1,REDO)=0
F S SUB1=$O(^AUPNGUAR(PATPTR,1,SUB1)) Q:'SUB1 D G REDO:REDO
.S SUB11=$O(^AUPNGUAR(PATPTR,1,SUB1,11,0))
.I 'SUB11 D Q
..S REDO=1 K DIE,DIK,DA,DIC S DA(1)=PATPTR,DA=SUB1,DIK="^AUPNGUAR("_DA(1)_",1," D ^DIK
Q
VAALERT ;EP - SEND VA ALERT IF WANTED
S XQAMSG="Patient Regsistration "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_" INSTALL complete."
S XQA("AG MAIL GROUP")=""
D SETUP^XQALERT
Q
;FIX STATE,SEX AND DOB FIELDS WHICH WERE INCORRECTLY STUFFED
POLHOLD ;
N IEN,DOB,STATE,SEX
S IEN=0
F S IEN=$O(^AUPN3PPH(IEN)) Q:'IEN D
.S STATE=$P($G(^AUPN3PPH(IEN,0)),U,12)
.S DOB=$P($G(^AUPN3PPH(IEN,0)),U,19)
.S SEX=$P($G(^AUPN3PPH(IEN,0)),U,8)
.Q:(STATE="")&(DOB="")&(SEX="")
.I STATE'="" D
..Q:+STATE>0 ;DON'T DO ANYTHING IF ALREADY A POINTER
..W !,IEN,"*",STATE
..K DIC
..S X=STATE
..S DIC=5
..D ^DIC
..Q:Y<0
..K DIE,DR,DIC,DA
..S DA=IEN
..S DIE="^AUPN3PPH("
..S DR=".12///^S X=STATE"
..D ^DIE
.I DOB'="" D
..Q:DOB'["/"
..W !,IEN,"*",DOB
..K DIE,DR,DIC,DA
..S DA=IEN
..S DIE="^AUPN3PPH("
..S DR=".19///^S X=DOB"
..D ^DIE
.I SEX'="" D
..Q:$L(SEX)=1
..W !,IEN,"*",SEX
..K DIE,DR,DIC,DA
..S DA=IEN
..S DIE="^AUPN3PPH("
..S DR=".08///^S X=SEX"
..D ^DIE
Q
PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn
Q:X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N 0
N %,I,J
S I=$O(^DIC(9.4,"C",$P(X,"*"),0)) Q:'I 0
S J=$O(^DIC(9.4,I,22,"B",$P(X,"*",2),0)),X=$P(X,"*",3) Q:'J 0
;check if patch is just a number
Q:$O(^DIC(9.4,I,22,J,"PAH","B",X,0)) 1
S %=$O(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
Q (X=+%)
;ADD CORRECT MANDATORY ADDRESS FIELDS FOR VA PATIENT
ADDMAN ;
K DA,DIC,DIE,DR,DO,DD,DINUM
S DUZ2=0
F S DUZ2=$O(^AGFAC(DUZ2)) Q:'DUZ2 D
.S DA(1)=$O(^AGFAC(DUZ2,11,"B",2,"")) ;JUST DO THIS FOR 'VA PATIENT' FILE
.;S DUZ2=516,DA(1)=1
.Q:'DA(1)
.S DA(2)=DUZ2
.S DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
.S X="STATE"
.S DIC(0)="LX"
.S DIC("DR")=".02///^S X=0"
.D ^DIC
.S X="ZIP CODE"
.S DIC(0)="LX"
.S DIC("DR")=".02///^S X=0"
.D ^DIC
.S X="CITY"
.S DIC(0)="LX"
.S DIC("DR")=".02///^S X=0"
.D ^DIC
.S X="STREET ADDRESS [LINE 1]"
.D ^DIC
Q
;FIX DANGLING "c" X-REF WITH NO POLICY HOLDER IN 11 NODE
POL ;
S POLH="" F S POLH=$O(^AUPNPRVT("C",POLH)) Q:POLH="" D
.S POLM="" F S POLM=$O(^AUPNPRVT("C",POLH,POLM)) Q:POLM="" D
..S REC="" F S REC=$O(^AUPNPRVT("C",POLH,POLM,REC)) Q:REC="" D
...I $P($G(^AUPNPRVT(POLM,11,REC,0)),U,8)'=POLH D
....W !,POLM,"**",REC,!?5,"POLH:",POLH
....W !?5,"PIECE 8:",$P($G(^AUPNPRVT(POLM,11,REC,0)),U,8)
....I $P($G(^AUPNPRVT(POLM,11,REC,0)),U,8)="" W !?5,"INSURER NODE:",$G(^AUPNPRVT(POLM,11,REC,0))
....I $P($G(^AUPNPRVT(POLM,11,REC,0)),U,8)="",($G(^AUPNPRVT(POLM,11,REC,0))="") K ^AUPNPRVT("C",POLH,POLM,REC)
Q
;
ADDHIST ;EP - ADD FIRST HISTORICAL ENTRY
N PADFN
S PATDFN=0
F S PATDFN=$O(^DPT(PATDFN)) Q:'PATDFN D
.Q:'$D(^AUPNPAT(PATDFN))
.D UPDTHADD^AGUTILS(PATDFN,"F") ;F MEANS FORCE THE DATA IN
Q
;
SETDEF ;EP - SET DEFAULTS IN NEW PARAMETERS
K DIE,DIR,DIC,DA
S DUZ2=0
F S DUZ2=$O(^AGFAC(DUZ2)) Q:'DUZ2 D
.S DA=DUZ2
.S DIE="^AGFAC("
.S DR="601////1;602////0"
.D ^DIE
Q
AG71A4 ;IHS/SD/EFG - Patient Registration 7.1 PATCH 4 PRE/POST INSTALL ;
+1 ;;7.1;PATIENT REGISTRATION;**2,3,4**;AUG 25,2005
+2 ;
+3 QUIT
PRE ;EP - From KIDS.
+1 ;'AG PATIENT REGISTRATION ERROR CODES' FILE
+2 ;FILE 9009061.5 IS DINUMED AND HAS IDENTIFIERS. KIDS WILL NOT TRANSFER
+3 ;NEW DATA FOR THOSE FIELDS WITHOUT FIRST KILLING THE GLOBAL DATA FIRST.
+4 ;ONLY NEED IF CHANGING DATA IN THIS FILE
+5 SET IEN=""
FOR
SET IEN=$ORDER(^AGEDERRS(IEN))
IF IEN=""
QUIT
KILL ^AGEDERRS(IEN)
+6 QUIT
POST ;EP - From KIDS.
+1 DO BMES^XPDUTL("Beginning post-install routine (POST^AG71A).")
DO TS
+2 ;
+3 ;CONVERT ENTRIES IN .04 IN AUPNPAT TO
+4 ;NEW MULTIPLE FIELD 3601 IN AUPNPAT
+5 ;DONE ONLY IF PATCH 1 NOT FOUND
+6 IF '$$PATCH("AG*7.1*1")
DO BMES^XPDUTL("Converting 'Release of Information' AUPNPAT field .04 to new multiple field 3601.")
DO TS
DO ^AGCNVROI
+7 ;
+8 DO BMES^XPDUTL("Fixing private eligibility with missing Policy Holder .08 field. or missing insurer pointer")
DO TS
+9 DO PRVT
+10 ;
+11 DO BMES^XPDUTL("Collecting Medicaid eligibility entries with missing State .04 field.")
DO TS
+12 DO MCD
+13 ;
+14 DO BMES^XPDUTL("Fixing Medicare eligibility B cross references.")
DO TS
+15 DO MCR
+16 ;
+17 DO BMES^XPDUTL("Fixing INSURER IENs containing decimal.")
DO TS
+18 DO INSURER
+19 ;
+20 DO BMES^XPDUTL("Fixing Medicare records with missing .01 fields")
DO TS
+21 DO MCR
+22 ;
+23 DO BMES^XPDUTL("Fixing Rail Road entries with missing .01 field.")
DO TS
+24 DO RRE
+25 ;
+26 DO BMES^XPDUTL("Fixing incomplete Guarantor records.")
DO TS
+27 DO GUAR
+28 ;
+29 DO BMES^XPDUTL("Fixing patient file with dangling D x-ref")
DO TS
+30 DO PAT
+31 ;
+32 DO BMES^XPDUTL("Fixing Policy Holder fields")
DO TS
+33 DO POLHOLD
+34 ;
+35 DO BMES^XPDUTL("Add File #2 VA PATIENT address fields as Site Mandatory field in the REGISTRATION PARAMETER file")
DO TS
+36 ;ADD MANDATORY ADDRESS FIELDS IN FILE 2 TO REGISTRATION PARAMETER FILE
DO ADDMAN
+37 ;
+38 ;TAKE CURRENT ADDRESS AND PHONE FOUND IN FILE #2 AND PLACE INTO THE NEW
+39 ;HISTORICAL MULTIPLES
+40 DO BMES^XPDUTL("Adding VA PATIENT address fields to PREVIOUS ADDRESS FIELD multiple of File #9000001")
DO TS
+41 ;
+42 SET X=$$LAST^XPDUTL("IHS PATIENT REGISTRATION","7.1")
+43 ;I $P(X,U)<4 D ADDHIST ;DO THIS ONLY ONCE
+44 ;RESTORE ABOVE LINE WHEN RELEASING.
DO ADDHIST
+45 ;
+46 ;SET DEAFULTS IN NEW PARAMETERS
DO SETDEF
+47 ;
+48 IF $$INSTALLD^AG71ENV("AG*7.1")
Begin DoDot:1
+49 DO TS
DO BMES^XPDUTL("Delivering AG*7.1 install message to select users ...")
+50 DO MAIL
+51 DO BMES^XPDUTL("Post-install routine is complete.")
DO TS
End DoDot:1
+52 ;
+53 IF $$INSTALLD^AG71ENV("AG*7.1")
QUIT
+54 ;
+55 DO TS
DO OPTRES("AGMENU")
+56 ;
+57 DO TS
DO BMES^XPDUTL("Delivering AG*7.1 install message to select users...")
+58 ;
+59 DO MAIL
+60 ;
+61 DO BMES^XPDUTL("Post-install routine is complete.")
DO TS
+62 QUIT
MAIL ;Send install mail message.
+1 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+2 KILL ^TMP("AG71MS",$JOB)
+3 SET ^TMP("AG71MS",$JOB,1)=" --- AG v 7.1 Patch 4 has been installed into this uci ---"
+4 SET ^TMP("AG71MS",$JOB,2)=" "
+5 SET CNT=3
+6 KILL AGERRLST
+7 SET %=0
+8 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
SET ^TMP("AG71MS",$JOB,(%+CNT))=" "_^(%,0)
+9 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""AG71MS"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+10 FOR %="AGZMENU","XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+11 DO ^XMD
+12 KILL ^TMP("AG71MS",$JOB)
+13 QUIT
SINGLE(K) ;EP - 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 ;
OPTRES(AGM) ;
+1 DO BMES^XPDUTL("Restoring '"_AGM_"' option to PRE-install configuration...")
+2 NEW AG,AGI
+3 IF '$DATA(^XTMP("AG71",7.2,"OPTSAV",AGM))
DO BMES^XPDUTL("FAILED. Option '"_AGM_"' was not previously saved.")
QUIT
+4 SET AG=0
+5 FOR
SET AG=$ORDER(^XTMP("AG71",7.2,"OPTSAV",AGM,AG))
IF 'AG
QUIT
SET AGI=^(AG)
IF '$$ADD^XPDMENU(AGM,$PIECE(AGI,U),$PIECE(AGI,U,2),$PIECE(AGI,U,3))
DO BMES^XPDUTL("....FAILED to re-attach "_$PIECE(AGI,U)_" to "_AGM_".")
+6 QUIT
TS DO MES^XPDUTL($$HTE^XLFDT($HOROLOG))
QUIT
MCD ;CLEAR MCD RECORDS MISSING .01 FIELD
+1 ;MUST DO DIRECT KILL BECAUSE X-REF NOT THERE. BOMBS ON USE OF ^DIK
+2 KILL AGERRLST
+3 NEW HRN,DFN,ST,MCDNUM
+4 SET RECNO=0
+5 FOR
SET RECNO=$ORDER(^AUPNMCD(RECNO))
IF 'RECNO
QUIT
Begin DoDot:1
+6 ;IF THE INS. PTR IS MISSING LETS FIX IT SO TPB CLAIMS GENERATOR DOESN'T BLOW UP
+7 IF '$GET(^AUPNMCD(RECNO,0))!('$PIECE($GET(^AUPNMCD(RECNO,0)),U))
KILL ^AUPNMCD(RECNO)
QUIT
+8 IF $PIECE($GET(^AUPNMCD(RECNO,0)),U,4)=""
SET DFN=$PIECE($GET(^AUPNMCD(RECNO,0)),U)
SET AGERRLST(RECNO)=$PIECE($GET(^DPT(DFN,0)),U)_U_$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
End DoDot:1
+9 QUIT
RRE ;FIX "B" X-REF ENTRIES WITH NO ZERO RECORD
+1 ;MUST DO DIRECT KILL BECAUSE RECORD NOT THERE. BOMBS ON USE OF ^DIK DOESN'T WORK
+2 SET RECNO=""
+3 FOR
SET RECNO=$ORDER(^AUPNRRE("B",RECNO))
IF 'RECNO
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNRRE(RECNO,0)),U)=""
KILL ^AUPNRRE(RECNO),^AUPNRRE("B",RECNO)
End DoDot:1
+5 SET RECNO=0
+6 FOR
SET RECNO=$ORDER(^AUPNRRE(RECNO))
IF 'RECNO
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^AUPNRRE(RECNO,0)),U)=""
KILL ^AUPNRRE(RECNO),^AUPNRRE("B",RECNO)
End DoDot:1
+8 QUIT
MCR ;
+1 SET RECNO=""
+2 FOR
SET RECNO=$ORDER(^AUPNMCR("B",RECNO))
IF 'RECNO
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNMCR(RECNO,0)),U)=""
KILL ^AUPNMCR(RECNO),^AUPNMCR("B",RECNO)
End DoDot:1
+4 SET RECNO=0
+5 FOR
SET RECNO=$ORDER(^AUPNMCR(RECNO))
IF 'RECNO
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^AUPNMCR(RECNO,0)),U)=""
KILL ^AUPNMCR(RECNO),^AUPNMCR("B",RECNO)
End DoDot:1
+7 QUIT
INSURER ;EP - CAN WE INCLUDE THIS IN AG PATCH 1??
+1 SET RECNO=0
+2 FOR
SET RECNO=$ORDER(^AUTNINS(RECNO))
IF 'RECNO
QUIT
Begin DoDot:1
+3 IF RECNO[(".")
KILL ^AUTNINS(RECNO),^AUTNINS("B",RECNO)
End DoDot:1
+4 SET RECNO=""
+5 FOR
SET RECNO=$ORDER(^AUTNINS("B",RECNO))
IF RECNO=""
QUIT
Begin DoDot:1
+6 SET RECIEN=""
+7 FOR
SET RECIEN=$ORDER(^AUTNINS("B",RECNO,RECIEN))
IF RECIEN=""
QUIT
Begin DoDot:2
+8 IF $PIECE($GET(^AUTNINS(RECIEN,0)),U)'=""
QUIT
+9 KILL DA,DIR,DIE,DIK,DIC,DR
+10 SET DA=RECIEN
SET DIK="^AUTNINS("
DO ^DIK
End DoDot:2
End DoDot:1
+11 QUIT
PAT ;CLEAN UP D X-REF IN PATIENT FILE
+1 SET HRN=""
FOR
SET HRN=$ORDER(^AUPNPAT("D",HRN))
IF HRN=""
QUIT
Begin DoDot:1
+2 SET RECNO=""
FOR
SET RECNO=$ORDER(^AUPNPAT("D",HRN,RECNO))
IF RECNO=""
QUIT
Begin DoDot:2
+3 IF '$DATA(^AUPNPAT(RECNO))!('$DATA(^DPT(RECNO)))
KILL ^AUPNPAT("D",HRN,RECNO)
End DoDot:2
End DoDot:1
+4 QUIT
PRVT ;CLEAR ANY PRIVATE ELIG RECORDS MISSING INSURER POINTER
+1 ;MUST DO DIRECT KILL BECAUSE X-REF NOT THERE. BOMBS ON USE OF ^DIK
+2 SET RECNO=0
+3 FOR
SET RECNO=$ORDER(^AUPNPRVT(RECNO))
IF 'RECNO
QUIT
Begin DoDot:1
+4 SET D1=0
+5 FOR
SET D1=$ORDER(^AUPNPRVT(RECNO,11,D1))
IF 'D1
QUIT
Begin DoDot:2
+6 IF $PIECE($GET(^AUPNPRVT(RECNO,11,D1,0)),U)=""
KILL ^AUPNPRVT(RECNO,11,D1)
QUIT
+7 IF $PIECE($GET(^AUPNPRVT(RECNO,11,D1,0)),U,8)=""
SET DA=D1
SET DA(1)=RECNO
SET DIK="^AUPNPRVT("_DA(1)_",11,"
DO ^DIK
+8 IF $ORDER(^AUPNPRVT(RECNO,11,0))
QUIT
+9 SET DA=RECNO
SET DIK="^AUPNPRVT("
DO ^DIK
End DoDot:2
End DoDot:1
+10 SET RECNO=0
FOR
SET RECNO=$ORDER(^AUPNPRVT("B",RECNO))
IF RECNO=""
QUIT
Begin DoDot:1
+11 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPRVT("B",RECNO,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+12 IF $PIECE($GET(^AUPNPRVT(IEN,0)),U)=""
KILL ^AUPNPRVT(IEN),^AUPNPRVT("B",RECNO,IEN)
End DoDot:2
End DoDot:1
+13 QUIT
GUAR ;CLEAR GUARANTOR RECORDS WITH INCOMPETE ENTRIES
+1 NEW PATPTR
+2 SET PATPTR=0
+3 FOR
SET PATPTR=$ORDER(^AUPNGUAR(PATPTR))
IF 'PATPTR
QUIT
DO GUAR1(PATPTR)
+4 QUIT
GUAR1(PATPTR) ;EP - DELETE GUARANTOR ENTRIES WITH MISSING GUARANTORS OR DATES
+1 NEW SUB1,SUB11,REDO
REDO ;
+1 SET SUB1=$ORDER(^AUPNGUAR(PATPTR,1,0))
+2 ;NO GUARANTORS FOUND AT ALL
IF 'SUB1
Begin DoDot:1
+3 KILL DIE,DIK,DA,DIC
SET DIK="^AUPNGUAR("
SET DA=PATPTR
DO ^DIK
End DoDot:1
QUIT
+4 ;FOR EACH GUARANTOR ARE THERE EFFECTIVE DATES?
+5 SET (SUB1,REDO)=0
+6 FOR
SET SUB1=$ORDER(^AUPNGUAR(PATPTR,1,SUB1))
IF 'SUB1
QUIT
Begin DoDot:1
+7 SET SUB11=$ORDER(^AUPNGUAR(PATPTR,1,SUB1,11,0))
+8 IF 'SUB11
Begin DoDot:2
+9 SET REDO=1
KILL DIE,DIK,DA,DIC
SET DA(1)=PATPTR
SET DA=SUB1
SET DIK="^AUPNGUAR("_DA(1)_",1,"
DO ^DIK
End DoDot:2
QUIT
End DoDot:1
IF REDO
GOTO REDO
+10 QUIT
VAALERT ;EP - SEND VA ALERT IF WANTED
+1 SET XQAMSG="Patient Regsistration "_$PIECE($TEXT(+2),";",3)_" Patch "_$PIECE($TEXT(+2),";",5)_" INSTALL complete."
+2 SET XQA("AG MAIL GROUP")=""
+3 DO SETUP^XQALERT
+4 QUIT
+5 ;FIX STATE,SEX AND DOB FIELDS WHICH WERE INCORRECTLY STUFFED
POLHOLD ;
+1 NEW IEN,DOB,STATE,SEX
+2 SET IEN=0
+3 FOR
SET IEN=$ORDER(^AUPN3PPH(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 SET STATE=$PIECE($GET(^AUPN3PPH(IEN,0)),U,12)
+5 SET DOB=$PIECE($GET(^AUPN3PPH(IEN,0)),U,19)
+6 SET SEX=$PIECE($GET(^AUPN3PPH(IEN,0)),U,8)
+7 IF (STATE="")&(DOB="")&(SEX="")
QUIT
+8 IF STATE'=""
Begin DoDot:2
+9 ;DON'T DO ANYTHING IF ALREADY A POINTER
IF +STATE>0
QUIT
+10 WRITE !,IEN,"*",STATE
+11 KILL DIC
+12 SET X=STATE
+13 SET DIC=5
+14 DO ^DIC
+15 IF Y<0
QUIT
+16 KILL DIE,DR,DIC,DA
+17 SET DA=IEN
+18 SET DIE="^AUPN3PPH("
+19 SET DR=".12///^S X=STATE"
+20 DO ^DIE
End DoDot:2
+21 IF DOB'=""
Begin DoDot:2
+22 IF DOB'["/"
QUIT
+23 WRITE !,IEN,"*",DOB
+24 KILL DIE,DR,DIC,DA
+25 SET DA=IEN
+26 SET DIE="^AUPN3PPH("
+27 SET DR=".19///^S X=DOB"
+28 DO ^DIE
End DoDot:2
+29 IF SEX'=""
Begin DoDot:2
+30 IF $LENGTH(SEX)=1
QUIT
+31 WRITE !,IEN,"*",SEX
+32 KILL DIE,DR,DIC,DA
+33 SET DA=IEN
+34 SET DIE="^AUPN3PPH("
+35 SET DR=".08///^S X=SEX"
+36 DO ^DIE
End DoDot:2
End DoDot:1
+37 QUIT
PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn
+1 IF X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N
QUIT 0
+2 NEW %,I,J
+3 SET I=$ORDER(^DIC(9.4,"C",$PIECE(X,"*"),0))
IF 'I
QUIT 0
+4 SET J=$ORDER(^DIC(9.4,I,22,"B",$PIECE(X,"*",2),0))
SET X=$PIECE(X,"*",3)
IF 'J
QUIT 0
+5 ;check if patch is just a number
+6 IF $ORDER(^DIC(9.4,I,22,J,"PAH","B",X,0))
QUIT 1
+7 SET %=$ORDER(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
+8 QUIT (X=+%)
+9 ;ADD CORRECT MANDATORY ADDRESS FIELDS FOR VA PATIENT
ADDMAN ;
+1 KILL DA,DIC,DIE,DR,DO,DD,DINUM
+2 SET DUZ2=0
+3 FOR
SET DUZ2=$ORDER(^AGFAC(DUZ2))
IF 'DUZ2
QUIT
Begin DoDot:1
+4 ;JUST DO THIS FOR 'VA PATIENT' FILE
SET DA(1)=$ORDER(^AGFAC(DUZ2,11,"B",2,""))
+5 ;S DUZ2=516,DA(1)=1
+6 IF 'DA(1)
QUIT
+7 SET DA(2)=DUZ2
+8 SET DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
+9 SET X="STATE"
+10 SET DIC(0)="LX"
+11 SET DIC("DR")=".02///^S X=0"
+12 DO ^DIC
+13 SET X="ZIP CODE"
+14 SET DIC(0)="LX"
+15 SET DIC("DR")=".02///^S X=0"
+16 DO ^DIC
+17 SET X="CITY"
+18 SET DIC(0)="LX"
+19 SET DIC("DR")=".02///^S X=0"
+20 DO ^DIC
+21 SET X="STREET ADDRESS [LINE 1]"
+22 DO ^DIC
End DoDot:1
+23 QUIT
+24 ;FIX DANGLING "c" X-REF WITH NO POLICY HOLDER IN 11 NODE
POL ;
+1 SET POLH=""
FOR
SET POLH=$ORDER(^AUPNPRVT("C",POLH))
IF POLH=""
QUIT
Begin DoDot:1
+2 SET POLM=""
FOR
SET POLM=$ORDER(^AUPNPRVT("C",POLH,POLM))
IF POLM=""
QUIT
Begin DoDot:2
+3 SET REC=""
FOR
SET REC=$ORDER(^AUPNPRVT("C",POLH,POLM,REC))
IF REC=""
QUIT
Begin DoDot:3
+4 IF $PIECE($GET(^AUPNPRVT(POLM,11,REC,0)),U,8)'=POLH
Begin DoDot:4
+5 WRITE !,POLM,"**",REC,!?5,"POLH:",POLH
+6 WRITE !?5,"PIECE 8:",$PIECE($GET(^AUPNPRVT(POLM,11,REC,0)),U,8)
+7 IF $PIECE($GET(^AUPNPRVT(POLM,11,REC,0)),U,8)=""
WRITE !?5,"INSURER NODE:",$GET(^AUPNPRVT(POLM,11,REC,0))
+8 IF $PIECE($GET(^AUPNPRVT(POLM,11,REC,0)),U,8)=""
IF ($GET(^AUPNPRVT(POLM,11,REC,0))="")
KILL ^AUPNPRVT("C",POLH,POLM,REC)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
ADDHIST ;EP - ADD FIRST HISTORICAL ENTRY
+1 NEW PADFN
+2 SET PATDFN=0
+3 FOR
SET PATDFN=$ORDER(^DPT(PATDFN))
IF 'PATDFN
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUPNPAT(PATDFN))
QUIT
+5 ;F MEANS FORCE THE DATA IN
DO UPDTHADD^AGUTILS(PATDFN,"F")
End DoDot:1
+6 QUIT
+7 ;
SETDEF ;EP - SET DEFAULTS IN NEW PARAMETERS
+1 KILL DIE,DIR,DIC,DA
+2 SET DUZ2=0
+3 FOR
SET DUZ2=$ORDER(^AGFAC(DUZ2))
IF 'DUZ2
QUIT
Begin DoDot:1
+4 SET DA=DUZ2
+5 SET DIE="^AGFAC("
+6 SET DR="601////1;602////0"
+7 DO ^DIE
End DoDot:1
+8 QUIT
