DG53372A ;ALB/PDJ - Convert Eligibility codes ; 03/29/2001
;;5.3;Registration;**372**;Aug 13, 1993
;
;
;
EN N DATA,ERRMSG,FILERR,LFDATE,DFN,I,X,X1,X2,%,CLNOK,NSTD,STDCDS,IEN,TEXT
N XTERR,XTPAT,XTENC,NAME
S CLNOK=0
;
S STDCDS(3)=$O(^DIC(8,"B","SC LESS THAN 50%",""))
S STDCDS(5)=$O(^DIC(8,"B","NSC",""))
;**** TEST CODE
; S STDCDS(3)=3
; S STDCDS(5)=100 ; or STDCDS(5)=2
;**** TEST CODE
I STDCDS(3)=3,STDCDS(5)=5 D Q ; Quit, because cleanup not needed
. S CLNOK=1
. D BMES^XPDUTL(" ")
. D BMES^XPDUTL(" ")
. D BMES^XPDUTL(" Your Site uses standard eligibility codes for NSC and")
. D BMES^XPDUTL(" SC LESS THAN 50% veterans, therefore no cleanup is needed. ")
. D BMES^XPDUTL(" ")
. D MAIL^DG53372M
;
; Are 3 and 5 currently in use?
;
F IEN=3,5 D
. S NSTD(IEN)=0
. I '$D(^DIC(8,IEN,0)) D Q
. . S NSTD(IEN)=1
. . D BMES^XPDUTL(" ")
. . D BMES^XPDUTL(" Your Site is using ELIGIBILITY CODE "_STDCDS(IEN)_" for "_$S(IEN=3:"SC LESS THAN 50%.",1:"NSC"))
. . D BMES^XPDUTL(" The post-install will now identify all PATIENT and PATIENT ENCOUNTER")
. . D BMES^XPDUTL(" records that are corrupted. You will receive a Mailman message ")
. . D BMES^XPDUTL(" listing the records that have been updated to use your local IEN.")
. . D BMES^XPDUTL(" Please review the mailman message as needed.")
. . D BMES^XPDUTL(" ")
. ;
. I STDCDS(IEN)'=IEN D
. . S NSTD(IEN)=2
. . D BMES^XPDUTL(" ")
. . D BMES^XPDUTL(" Your Site is currently using ELIGIBILITY CODE "_IEN_" for "_$P(^DIC(8,IEN,0),"^",1)_".")
. . D BMES^XPDUTL(" This is non-standard, as this code should be used for "_$S(IEN=3:"SC LESS THAN 50%.",1:"NSC."))
. . D BMES^XPDUTL(" The post-install will now identify all PATIENT and PATIENT ENCOUNTER")
. . D BMES^XPDUTL(" records that may be corrupted. You will receive a Mailman message ")
. . D BMES^XPDUTL(" listing the records. Please review the records and update manually as")
. . D BMES^XPDUTL(" needed.")
. . D BMES^XPDUTL(" ")
;
S (ERRMSG,FILERR)=""
;
I $D(XPDNM) D
. I $$VERCP^XPDUTL("DFN")'>0 D
. . S %=$$NEWCP^XPDUTL("DFN","","0")
;
F I="PATREC","ENCREC","SRCERR" D
. I $D(^XTMP("DG*5.3*372-"_I)) Q
. S X1=DT
. S X2=30
. D C^%DTC
. S TEXT=X_"^"_$$DT^XLFDT_"^DG*5.3*372 POST-INSTALL "
. S TEXT=TEXT_$S(I="PATREC":"Patient Records",I="ENCREC":"Encounter Records",1:"filing errors")
. S ^XTMP("DG*5.3*372-"_I,0)=TEXT
;
S XTPAT="DG*5.3*372-PATREC"
S XTENC="DG*5.3*372-ENCREC"
S XTERR="DG*5.3*372-SRCERR"
;
I '$D(XPDNM) D
. S ^XTMP(XTPAT,1)=0
. S ^XTMP(XTENC,1)=0
I $D(XPDNM)&'$D(^XTMP(XTPAT,1)) S ^XTMP(XTPAT,1)=0
I $D(XPDNM)&'$D(^XTMP(XTENC,1)) S ^XTMP(XTENC,1)=0
I $D(XPDNM)&'$D(^XTMP(XTERR,1)) S ^XTMP(XTERR,1)=0
I $D(XPDNM) S %=$$VERCP^XPDUTL("DFN")
I $G(%)="" S %=0
I %=0 D EN1
Q
;
EN1 I '$D(XPDNM) S DFN=0
I $D(XPDNM) S DFN=$$PARCP^XPDUTL("DFN")
F S DFN=$O(^DPT(DFN)) Q:'DFN D
. ;
. ; Identify Records
. ;
. S NAME=$P($G(^DPT(DFN,0)),"^",1)
. D PROCENC
. D PROCELG
. D PROCSELG
. I $D(XPDNM) S %=$$UPCP^XPDUTL("DFN",DFN)
;
D MAIL^DG53372M
I $D(XPDNM) S %=$$COMCP^XPDUTL("DFN")
D BMES^XPDUTL(" Cleanup of Eligibility Code is complete.")
Q
;
PROCENC ; Process PATIENT ENCOUNTER file
N DATA,ELIGCD,ERROR,SCEDT,SCEIEN
; Set beginning date as release date for DG*5.3*327
S SCEDT=3010214.99999999,SCEIEN=""
;
; Loop through all OUTPATIENT ENCOUNTERS for this PATIENT
; since DG*5.3*327 was released to NVS
;
F S SCEDT=$O(^SCE("ADFN",DFN,SCEDT)) Q:'SCEDT D
. F S SCEIEN=$O(^SCE("ADFN",DFN,SCEDT,SCEIEN)) Q:'SCEIEN D
. . S ELIGCD=$P(^SCE(SCEIEN,0),"^",13) Q:ELIGCD=""
. . I ",3,5,"'[ELIGCD Q ; Quit, if not code 3 or 5
. . I NSTD(ELIGCD)=0 Q ; Quit, if the site uses the standard code
. . ;
. . ; Add entry to Temp File for list or auto-correct
. . ;
. . S ^XTMP(XTENC,ELIGCD,DFN,SCEIEN)=NAME_"^"_SCEDT
. . S ^XTMP(XTENC,1)=^XTMP(XTENC,1)+1
. . ;
. . ; Auto-update the Eligibility code to the site code
. . ;
. . I NSTD(ELIGCD)=1 D
. . . S DATA(.13)=STDCDS(ELIGCD)
. . . I '$$UPD^DGENDBS(409.68,SCEIEN,.DATA,.ERROR) D
. . . . S ^XTMP(XTERR,409.68,ELIGCD,DFN,SCEIEN)=NAME_"^"_SCEDT_"^"_$G(ERROR)
Q
;
PROCELG ; Process PATIENT file
N DA,DATA,ELIGCD,ERROR
S ELIGCD=$P($G(^DPT(DFN,.36)),"^",1) Q:ELIGCD="" ; Quit,if null
I ",3,5,"'[ELIGCD Q ; Quit, if not code 3 or 5
I NSTD(ELIGCD)=0 Q ; Quit, if the site uses the standard code
;
; Add entry to Temp File for list or auto-correct
;
S ^XTMP(XTPAT,ELIGCD,DFN,0)=NAME_"^"
S ^XTMP(XTPAT,1)=^XTMP(XTPAT,1)+1
;
; Auto-update the Eligibility code to the site code
;
I NSTD(ELIGCD)=1 D
. S DATA(.361)=STDCDS(ELIGCD)
. I '$$UPD^DGENDBS(2,DFN,.DATA,.ERROR) D
. . S ^XTMP(XTERR,2,ELIGCD,DFN,0)=NAME_"^^"_$G(ERROR)
Q
;
PROCSELG ; Process secondary eligibility codes
N DA,DATA,SIEN,NODE,FDAIEN,NEWIEN,DIK
S SIEN=0
F S SIEN=$O(^DPT(DFN,"E",SIEN)) Q:'SIEN D
. S NODE=$G(^DPT(DFN,"E",SIEN,0))
. S ELIGCD=$P(NODE,"^",1) Q:ELIGCD="" ; Quit, if null
. I ",3,5,"'[ELIGCD Q ; Quit, if not code 3 or 5
. I NSTD(ELIGCD)=0 Q ;Quit, if the site uses the standard code
. ;
. ; Add entry to Temp File for list or auto-correct
. ;
. S ^XTMP(XTPAT,ELIGCD,DFN,SIEN)=NAME_"^"_ELIGCD
. S ^XTMP(XTPAT,1,1)=$G(^XTMP(XTPAT,1,1))+1
. ;
. ; Update entry for auto-correct
. ;
. I NSTD(ELIGCD)=1 D
. . I '$D(^DPT(DFN,"E",STDCDS(ELIGCD))) D
. . . K DATA,FDAIEN,NEWIEN,ERROR
. . . S NEWIEN="+1,"_DFN_","
. . . S DATA(2.0361,NEWIEN,.01)=STDCDS(ELIGCD)
. . . S DATA(2.0361,NEWIEN,.03)=$P(NODE,"^",3)
. . . S DATA(2.0361,NEWIEN,.04)=$P(NODE,"^",4)
. . . S FDAIEN(1)=STDCDS(ELIGCD)
. . . D UPDATE^DIE("","DATA","FDAIEN","ERROR")
. . . I $D(ERROR) D Q
. . . . S ^XTMP(XTERR,2.0361,ELIGCD,DFN,SIEN)=NAME_"^"_SIEN_"^"_$G(ERROR)
. . ; Delete old entry if add successful.
. . K DA,DATA
. . S DA(1)=DFN,DA=ELIGCD,DIK="^DPT("_DA(1)_",""E"","
. . D ^DIK
Q
;
CLEANUP ; Used to cleanup XTMP global for testing only
S XTPAT="DG*5.3*372-PATREC"
S XTENC="DG*5.3*372-ENCREC"
S XTERR="DG*5.3*372-SRCERR"
;
K ^XTMP(XTPAT)
K ^XTMP(XTENC)
K ^XTMP(XTERR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53372A 6224 printed Apr 09, 2024@22:05:37 Page 2
DG53372A ;ALB/PDJ - Convert Eligibility codes ; 03/29/2001
+1 ;;5.3;Registration;**372**;Aug 13, 1993
+2 ;
+3 ;
+4 ;
EN NEW DATA,ERRMSG,FILERR,LFDATE,DFN,I,X,X1,X2,%,CLNOK,NSTD,STDCDS,IEN,TEXT
+1 NEW XTERR,XTPAT,XTENC,NAME
+2 SET CLNOK=0
+3 ;
+4 SET STDCDS(3)=$ORDER(^DIC(8,"B","SC LESS THAN 50%",""))
+5 SET STDCDS(5)=$ORDER(^DIC(8,"B","NSC",""))
+6 ;**** TEST CODE
+7 ; S STDCDS(3)=3
+8 ; S STDCDS(5)=100 ; or STDCDS(5)=2
+9 ;**** TEST CODE
+10 ; Quit, because cleanup not needed
IF STDCDS(3)=3
IF STDCDS(5)=5
Begin DoDot:1
+11 SET CLNOK=1
+12 DO BMES^XPDUTL(" ")
+13 DO BMES^XPDUTL(" ")
+14 DO BMES^XPDUTL(" Your Site uses standard eligibility codes for NSC and")
+15 DO BMES^XPDUTL(" SC LESS THAN 50% veterans, therefore no cleanup is needed. ")
+16 DO BMES^XPDUTL(" ")
+17 DO MAIL^DG53372M
End DoDot:1
QUIT
+18 ;
+19 ; Are 3 and 5 currently in use?
+20 ;
+21 FOR IEN=3,5
Begin DoDot:1
+22 SET NSTD(IEN)=0
+23 IF '$DATA(^DIC(8,IEN,0))
Begin DoDot:2
+24 SET NSTD(IEN)=1
+25 DO BMES^XPDUTL(" ")
+26 DO BMES^XPDUTL(" Your Site is using ELIGIBILITY CODE "_STDCDS(IEN)_" for "_$SELECT(IEN=3:"SC LESS THAN 50%.",1:"NSC"))
+27 DO BMES^XPDUTL(" The post-install will now identify all PATIENT and PATIENT ENCOUNTER")
+28 DO BMES^XPDUTL(" records that are corrupted. You will receive a Mailman message ")
+29 DO BMES^XPDUTL(" listing the records that have been updated to use your local IEN.")
+30 DO BMES^XPDUTL(" Please review the mailman message as needed.")
+31 DO BMES^XPDUTL(" ")
End DoDot:2
QUIT
+32 ;
+33 IF STDCDS(IEN)'=IEN
Begin DoDot:2
+34 SET NSTD(IEN)=2
+35 DO BMES^XPDUTL(" ")
+36 DO BMES^XPDUTL(" Your Site is currently using ELIGIBILITY CODE "_IEN_" for "_$PIECE(^DIC(8,IEN,0),"^",1)_".")
+37 DO BMES^XPDUTL(" This is non-standard, as this code should be used for "_$SELECT(IEN=3:"SC LESS THAN 50%.",1:"NSC."))
+38 DO BMES^XPDUTL(" The post-install will now identify all PATIENT and PATIENT ENCOUNTER")
+39 DO BMES^XPDUTL(" records that may be corrupted. You will receive a Mailman message ")
+40 DO BMES^XPDUTL(" listing the records. Please review the records and update manually as")
+41 DO BMES^XPDUTL(" needed.")
+42 DO BMES^XPDUTL(" ")
End DoDot:2
End DoDot:1
+43 ;
+44 SET (ERRMSG,FILERR)=""
+45 ;
+46 IF $DATA(XPDNM)
Begin DoDot:1
+47 IF $$VERCP^XPDUTL("DFN")'>0
Begin DoDot:2
+48 SET %=$$NEWCP^XPDUTL("DFN","","0")
End DoDot:2
End DoDot:1
+49 ;
+50 FOR I="PATREC","ENCREC","SRCERR"
Begin DoDot:1
+51 IF $DATA(^XTMP("DG*5.3*372-"_I))
QUIT
+52 SET X1=DT
+53 SET X2=30
+54 DO C^%DTC
+55 SET TEXT=X_"^"_$$DT^XLFDT_"^DG*5.3*372 POST-INSTALL "
+56 SET TEXT=TEXT_$SELECT(I="PATREC":"Patient Records",I="ENCREC":"Encounter Records",1:"filing errors")
+57 SET ^XTMP("DG*5.3*372-"_I,0)=TEXT
End DoDot:1
+58 ;
+59 SET XTPAT="DG*5.3*372-PATREC"
+60 SET XTENC="DG*5.3*372-ENCREC"
+61 SET XTERR="DG*5.3*372-SRCERR"
+62 ;
+63 IF '$DATA(XPDNM)
Begin DoDot:1
+64 SET ^XTMP(XTPAT,1)=0
+65 SET ^XTMP(XTENC,1)=0
End DoDot:1
+66 IF $DATA(XPDNM)&'$DATA(^XTMP(XTPAT,1))
SET ^XTMP(XTPAT,1)=0
+67 IF $DATA(XPDNM)&'$DATA(^XTMP(XTENC,1))
SET ^XTMP(XTENC,1)=0
+68 IF $DATA(XPDNM)&'$DATA(^XTMP(XTERR,1))
SET ^XTMP(XTERR,1)=0
+69 IF $DATA(XPDNM)
SET %=$$VERCP^XPDUTL("DFN")
+70 IF $GET(%)=""
SET %=0
+71 IF %=0
DO EN1
+72 QUIT
+73 ;
EN1 IF '$DATA(XPDNM)
SET DFN=0
+1 IF $DATA(XPDNM)
SET DFN=$$PARCP^XPDUTL("DFN")
+2 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+3 ;
+4 ; Identify Records
+5 ;
+6 SET NAME=$PIECE($GET(^DPT(DFN,0)),"^",1)
+7 DO PROCENC
+8 DO PROCELG
+9 DO PROCSELG
+10 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DFN",DFN)
End DoDot:1
+11 ;
+12 DO MAIL^DG53372M
+13 IF $DATA(XPDNM)
SET %=$$COMCP^XPDUTL("DFN")
+14 DO BMES^XPDUTL(" Cleanup of Eligibility Code is complete.")
+15 QUIT
+16 ;
PROCENC ; Process PATIENT ENCOUNTER file
+1 NEW DATA,ELIGCD,ERROR,SCEDT,SCEIEN
+2 ; Set beginning date as release date for DG*5.3*327
+3 SET SCEDT=3010214.99999999
SET SCEIEN=""
+4 ;
+5 ; Loop through all OUTPATIENT ENCOUNTERS for this PATIENT
+6 ; since DG*5.3*327 was released to NVS
+7 ;
+8 FOR
SET SCEDT=$ORDER(^SCE("ADFN",DFN,SCEDT))
if 'SCEDT
QUIT
Begin DoDot:1
+9 FOR
SET SCEIEN=$ORDER(^SCE("ADFN",DFN,SCEDT,SCEIEN))
if 'SCEIEN
QUIT
Begin DoDot:2
+10 SET ELIGCD=$PIECE(^SCE(SCEIEN,0),"^",13)
if ELIGCD=""
QUIT
+11 ; Quit, if not code 3 or 5
IF ",3,5,"'[ELIGCD
QUIT
+12 ; Quit, if the site uses the standard code
IF NSTD(ELIGCD)=0
QUIT
+13 ;
+14 ; Add entry to Temp File for list or auto-correct
+15 ;
+16 SET ^XTMP(XTENC,ELIGCD,DFN,SCEIEN)=NAME_"^"_SCEDT
+17 SET ^XTMP(XTENC,1)=^XTMP(XTENC,1)+1
+18 ;
+19 ; Auto-update the Eligibility code to the site code
+20 ;
+21 IF NSTD(ELIGCD)=1
Begin DoDot:3
+22 SET DATA(.13)=STDCDS(ELIGCD)
+23 IF '$$UPD^DGENDBS(409.68,SCEIEN,.DATA,.ERROR)
Begin DoDot:4
+24 SET ^XTMP(XTERR,409.68,ELIGCD,DFN,SCEIEN)=NAME_"^"_SCEDT_"^"_$GET(ERROR)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
PROCELG ; Process PATIENT file
+1 NEW DA,DATA,ELIGCD,ERROR
+2 ; Quit,if null
SET ELIGCD=$PIECE($GET(^DPT(DFN,.36)),"^",1)
if ELIGCD=""
QUIT
+3 ; Quit, if not code 3 or 5
IF ",3,5,"'[ELIGCD
QUIT
+4 ; Quit, if the site uses the standard code
IF NSTD(ELIGCD)=0
QUIT
+5 ;
+6 ; Add entry to Temp File for list or auto-correct
+7 ;
+8 SET ^XTMP(XTPAT,ELIGCD,DFN,0)=NAME_"^"
+9 SET ^XTMP(XTPAT,1)=^XTMP(XTPAT,1)+1
+10 ;
+11 ; Auto-update the Eligibility code to the site code
+12 ;
+13 IF NSTD(ELIGCD)=1
Begin DoDot:1
+14 SET DATA(.361)=STDCDS(ELIGCD)
+15 IF '$$UPD^DGENDBS(2,DFN,.DATA,.ERROR)
Begin DoDot:2
+16 SET ^XTMP(XTERR,2,ELIGCD,DFN,0)=NAME_"^^"_$GET(ERROR)
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
PROCSELG ; Process secondary eligibility codes
+1 NEW DA,DATA,SIEN,NODE,FDAIEN,NEWIEN,DIK
+2 SET SIEN=0
+3 FOR
SET SIEN=$ORDER(^DPT(DFN,"E",SIEN))
if 'SIEN
QUIT
Begin DoDot:1
+4 SET NODE=$GET(^DPT(DFN,"E",SIEN,0))
+5 ; Quit, if null
SET ELIGCD=$PIECE(NODE,"^",1)
if ELIGCD=""
QUIT
+6 ; Quit, if not code 3 or 5
IF ",3,5,"'[ELIGCD
QUIT
+7 ;Quit, if the site uses the standard code
IF NSTD(ELIGCD)=0
QUIT
+8 ;
+9 ; Add entry to Temp File for list or auto-correct
+10 ;
+11 SET ^XTMP(XTPAT,ELIGCD,DFN,SIEN)=NAME_"^"_ELIGCD
+12 SET ^XTMP(XTPAT,1,1)=$GET(^XTMP(XTPAT,1,1))+1
+13 ;
+14 ; Update entry for auto-correct
+15 ;
+16 IF NSTD(ELIGCD)=1
Begin DoDot:2
+17 IF '$DATA(^DPT(DFN,"E",STDCDS(ELIGCD)))
Begin DoDot:3
+18 KILL DATA,FDAIEN,NEWIEN,ERROR
+19 SET NEWIEN="+1,"_DFN_","
+20 SET DATA(2.0361,NEWIEN,.01)=STDCDS(ELIGCD)
+21 SET DATA(2.0361,NEWIEN,.03)=$PIECE(NODE,"^",3)
+22 SET DATA(2.0361,NEWIEN,.04)=$PIECE(NODE,"^",4)
+23 SET FDAIEN(1)=STDCDS(ELIGCD)
+24 DO UPDATE^DIE("","DATA","FDAIEN","ERROR")
+25 IF $DATA(ERROR)
Begin DoDot:4
+26 SET ^XTMP(XTERR,2.0361,ELIGCD,DFN,SIEN)=NAME_"^"_SIEN_"^"_$GET(ERROR)
End DoDot:4
QUIT
End DoDot:3
+27 ; Delete old entry if add successful.
+28 KILL DA,DATA
+29 SET DA(1)=DFN
SET DA=ELIGCD
SET DIK="^DPT("_DA(1)_",""E"","
+30 DO ^DIK
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
CLEANUP ; Used to cleanup XTMP global for testing only
+1 SET XTPAT="DG*5.3*372-PATREC"
+2 SET XTENC="DG*5.3*372-ENCREC"
+3 SET XTERR="DG*5.3*372-SRCERR"
+4 ;
+5 KILL ^XTMP(XTPAT)
+6 KILL ^XTMP(XTENC)
+7 KILL ^XTMP(XTERR)
+8 QUIT
