AUMSCBU ;IHS/OIT/NKD - SCB UPDATE - UTILITY 12/07/2012 ;
;;19.0;TABLE MAINTENANCE;**1**;SEP 04,2018;Build 1
; 03/12/14 - Modified Inactivate processing for Education tables
; 05/28/14 - Added Tribe pre-routine for Inactivate processing
; - Corrected condition to trigger Patient Current Community change
; 12/16/14 - Removed old/unused code
; 05/29/15 - Added Clinic Stop Inactivate processing
; - Added Clinic report
; 12/22/15 - Added Health Factor tag for New processing
; 08/22/16 - Modified Inactivate processing for Patient Status Code
; 12/04/17 - Removed Health Factor IEN restriction
; 03/15/18 - Added Revenue Codes table Pre and New processing
;
Q
; CUSTOM PRE-ROUTINES
CNTYPRE ; EP - COUNTY - INPUT TRANSFORMS
S L1=P1_P2
S:P1]"" P1A=$O(^DIC(5,"C",P1,0))
S P7=$S(P7]"":P7-17000000,1:"")
S:P7]"" AUMA="INA",INA=1
I 'P1A,'INA D ERR^AUMSCBD("Invalid STATE code: "_P1)
Q
COMPRE ; EP - COMMUNITY - INPUT TRANSFORMS
N CNT,TEXT,AUMR
S L1=P1_P2_P3
S:P1]"" P1A=$O(^DIC(5,"C",P1,0))
K AUMR F CNT=1:1 S TEXT=$P($T(CNTY+CNT^AUMSCBM),";;",2) Q:TEXT="END" S:TEXT="SEA" AUMR=$P($T(CNTY+CNT^AUMSCBM),";;",3)
I $D(AUMR) D
. N L1
. S L1=P1_P2
. S:P2]"" P2A=$$SEARCH^AUMSCBD(AUMR)
S:P5]"" P5A=$O(^AUTTAREA("C",P5,0))
K AUMR F CNT=1:1 S TEXT=$P($T(SU+CNT^AUMSCBM),";;",2) Q:TEXT="END" S:TEXT="SEA" AUMR=$P($T(SU+CNT^AUMSCBM),";;",3)
I $D(AUMR) D
. N L1
. S L1=P5_P6
. S:P6]"" P6A=$$SEARCH^AUMSCBD(AUMR)
S P7=$S(P7]"":P7-17000000,1:"")
S:P7]"" AUMA="INA",INA=1
I 'P1A,'INA D ERR^AUMSCBD("Invalid STATE code: "_P1)
I 'P2A,'INA D ERR^AUMSCBD("Invalid COUNTY code: "_P1_P2)
I 'P5A,'INA D ERR^AUMSCBD("Invalid AREA code: "_P5)
I 'P6A,'INA D ERR^AUMSCBD("Invalid SERVICE UNIT code: "_P5_P6)
Q
EDTPRE ; EP - EDUCATION TOPIC - INPUT TRANSFORMS AND LOOKUP
N CNT,AUMR
S P1=$$CLEAN^AUMSCBD(P1),P2=$$CLEAN^AUMSCBD(P2),P3=$$CLEAN^AUMSCBD(P3),P7=$S(P7]"":P7-17000000,1:"") ; IHS/OIT/NKD AUM*14.0*2
S P1A=P3_"-"_P1,P2A=P3_"-"_P2,P3A=$O(^AUTTEDMT("B",P3,0))
S:P7]"" AUMA="INA",INA=1 ; IHS/OIT/NKD AUM*14.0*2
D FIND^DIC(9999999.09,"","@;.01","PX",P1A,,"B",,,"AUMR")
S CNT=$P($G(AUMR("DILIST",0)),U,1)
S AUMI=$S(CNT=1:$P($G(AUMR("DILIST",1,0)),U,1),CNT>1:$P($G(AUMR("DILIST",$P($G(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
I 'AUMI D
. K AUMR
. D FIND^DIC(9999999.09,"","@;.01","PX",P2A,,"C","I ($P(^(0),U,3)'=1),($P(^(0),U)=$$UP^XLFSTR($P(^(0),U)))",,"AUMR")
. S CNT=$P($G(AUMR("DILIST",0)),U,1)
. S AUMI=$S(CNT=1:$P($G(AUMR("DILIST",1,0)),U,1),CNT>1:$P($G(AUMR("DILIST",$P($G(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
Q
LOCPRE ; EP - LOCATION - INPUT TRANSFORMS
N CNT,TEXT,AUMR
S L1=P1_P2_P3
S:P1]"" P1A=$O(^AUTTAREA("C",P1,0))
F CNT=1:1 S TEXT=$P($T(SU+CNT^AUMSCBM),";;",2) Q:TEXT="END" S:TEXT="SEA" AUMR=$P($T(SU+CNT^AUMSCBM),";;",3)
I $D(AUMR) D
. N L1
. S L1=P1_P2
. S:P2]"" P2A=$$SEARCH^AUMSCBD(AUMR)
S P7=$S(P7]"":P7-17000000,1:"")
S:P7]"" AUMA="INA",INA=1
I 'P1A,'INA D ERR^AUMSCBD("Invalid AREA code: "_P1)
I 'P2A,'INA D ERR^AUMSCBD("Invalid SERVICE UNIT code: "_P1_P2)
Q
MEASPRE ; EP - MEASUREMENT TYPE - INPUT TRANSFORMS
S P6=$TR(P6,"|",U)
Q
MJTPRE ; EP - EDUCATION MAJOR TOPIC - INPUT TRANSFORMS
S P1=$$CLEAN^AUMSCBD(P1),P2=$$CLEAN^AUMSCBD(P2),P7=$S(P7]"":P7-17000000,1:"") ; IHS/OIT/NKD AUM*14.0*2
S:P7]"" AUMA="INA",INA=1 ; IHS/OIT/NKD AUM*14.0*2
Q
RESPRE ; EP - RESERVATION - INPUT TRANSFORMS
S:P3]"" P3A=$O(^AUTTAREA("C",P3,0))
S:P4]"" P4A=$O(^DIC(5,"C",P4,0))
I 'P3A,'INA D ERR^AUMSCBD("Invalid AREA code: "_P3)
I 'P4A,'INA D ERR^AUMSCBD("Invalid STATE code: "_P4)
Q
STNMPRE ; EP - STATION NUMBER - INPUT TRANSFORMS AND LOOKUP
S:P2]"" P2A=$O(^AUTTLOC("C",P2,0))
Q:'P2A&INA
I 'P2A D ERR^AUMSCBD("LOCATION not found: "_P2) Q
Q:'$D(^DIC(4,P2A,0))&INA
I '$D(^DIC(4,P2A,0)) D ERR^AUMSCBD("INSTITUTION not found: "_P2) Q
S AUMI=P2A
Q
SUPRE ; EP - SERVICE UNIT - INPUT TRANSFORMS
S L1=P1_P2
S:P1]"" P1A=$O(^AUTTAREA("C",P1,0))
S P7=$S(P7]"":P7-17000000,1:"")
S:P7]"" AUMA="INA",INA=1
I 'P1A,'INA D ERR^AUMSCBD("Invalid AREA code: "_P1)
Q
STPRE ; EP - STATE - LOOKUP
N CNT,AUMR
S P7=$S(P7]"":P7-17000000,1:"")
S:P7]"" AUMA="INA",INA=1
D FIND^DIC(5,"","@;.01","PX",P1,,"B",,,"AUMR")
S CNT=$P($G(AUMR("DILIST",0)),U,1)
S AUMI=$S(CNT=1:$P($G(AUMR("DILIST",1,0)),U,1),CNT>1:$P($G(AUMR("DILIST",$P($G(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
I 'AUMI D
. K AUMR
. D FIND^DIC(5,"","@;.01","PX",P3,,"C","I $P(^(0),U,3)=P3",,"AUMR") ; SCREEN TO REMOVE ENTRIES THAT DON'T MATCH
. S CNT=$P($G(AUMR("DILIST",0)),U,1)
. S AUMI=$S(CNT=1:$P($G(AUMR("DILIST",1,0)),U,1),CNT>1:$P($G(AUMR("DILIST",$P($G(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
Q
HFPRE ; EP - HEALTH FACTOR - INPUT TRANSFORMS
N CNT,AUMR
; SEARCH FOR ACTIVE CATEGORIES MATCHING NAME
D FIND^DIC(9999999.64,"","@;.01","PX",P3,,"B","I $P(^(0),U,10)'=""F"",$P(^(0),U,13)'=""1""",,"AUMR")
S CNT=$P($G(AUMR("DILIST",0)),U,1)
S P3A=$S(CNT=1:$P($G(AUMR("DILIST",1,0)),U,1),CNT>1:$P($G(AUMR("DILIST",$P($G(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
; IF NO MATCHES FOUND, SEARCH FOR CATEGORIES MATCHING NAME
I 'P3A D
. K AUMR
. D FIND^DIC(9999999.64,"","@;.01","PX",P3,,"B","I $P(^(0),U,10)'=""F""",,"AUMR")
. S CNT=$P($G(AUMR("DILIST",0)),U,1)
. S P3A=$S(CNT=1:$P($G(AUMR("DILIST",1,0)),U,1),CNT>1:$P($G(AUMR("DILIST",$P($G(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
;I 'P3A,'INA D ERR^AUMSCBD("Invalid CATEGORY code: "_P3) ; IHS/OIT/NKD AUM*16.0*1 - LOGIC CHANGE FOR HF CATEGORY CREATION
I 'P3A,'INA,P4'="C" D ERR^AUMSCBD("Invalid CATEGORY code: "_P3)
Q
LANGPRE ; EP - LANGUAGES - INPUT TRANSFORMS
S P2=$$UP^XLFSTR(P2),P3=$$UP^XLFSTR(P3)
Q
PSCPRE ; EP - PATIENT STATUS CODE - INPUT TRANSFORMS
S P1A=P1_" "
S:P4]"" AUMA="INA",INA=1 ; IHS/OIT/NKD AUM*16.0*4 - INACTIVATE PROCESSING
Q
AREAPRE ; EP - AREA - INPUT TRANSFORMS
S P7=$S(P7]"":P7-17000000,1:"")
S:P7]"" AUMA="INA",INA=1
Q
CLINPRE ; EP - CLINIC STOP - INPUT TRANSFORMS
S P4A=$S(P4="Y":ONE,P4="N":AT,1:"")
S P7=$S(P7]"":P7-17000000,1:"") ; IHS/OIT/NKD AUM*15.0*3 - INACTIVATE PROCESSING
S:P7]"" AUMA="INA",INA=1,P2="x"_P2
Q
; IHS/OIT/NKD AUM*14.0*3 - ADDED TRIBE PRE
TRIPRE ; EP - TRIBE - INPUT TRANSFORMS
S P7=$S(P7]"":"Y",1:"")
S:P7]"" AUMA="INA",INA=1
Q
; IHS/OIT/NKD AUM*18.0*2 - ADDED REVENUE CODES PRE
REVPRE ; EP - REVENUE CODES - CREATE REVENUE CODES ENTRY
S P1A=+P1 S:P1A AUMI=$S($D(^AUTTREVN(P1A)):P1A,1:0)
S:P7 AUMA="INA",INA=1
Q
; CUSTOM NEW-ROUTINES
LOCNEW ; EP - LOCATION - CREATE INSTITUTION AND LOCATION ENTRIES
N FDA,NEWIEN,ERR,DINUM
F DINUM=+$P(^DIC(4,0),U,3):1 Q:'$D(^DIC(4,DINUM))&('$D(^AUTTLOC(DINUM))) I DINUM>99999 D ERR^AUMSCBD("SYSTEM ERROR - DINUM FOR LOC/INSTITUTION TOO BIG") Q
Q:DINUM>99999
S FDA(4,"+1,",.01)=P4
S NEWIEN(1)=DINUM
D UPDATE^DIE(,"FDA","NEWIEN","ERR")
I $D(ERR) D ERR^AUMSCBD("SYSTEM ERROR - New INSTITUTION failed") Q
S AUMI=NEWIEN(1)
I '$D(^AUTTLOC(AUMI)) D
. K FDA,NEWIEN,ERR
. S FDA(9999999.06,"+1,",.01)=AUMI
. S FDA(9999999.06,"+1,",.04)=P1A
. S FDA(9999999.06,"+1,",.07)=P3
. S FDA(9999999.06,"+1,",.32)=P6
. S NEWIEN(1)=AUMI
. D UPDATE^DIE(,"FDA","NEWIEN","ERR")
. I $D(ERR) D ERR^AUMSCBD("SYSTEM ERROR - New LOCATION failed") Q
. I AUMI'=NEWIEN(1) D ERR^AUMSCBD("SYSTEM ERROR - INSTITUTION/LOCATION IEN mismatch") Q
Q
; IHS/OIT/NKD AUM*16.0*1 - ADDED HEALTH FACTORS NEW
HFNEW ; EP - HEALTH FACTORS - CREATE HEALTH FACTOR ENTRY
N FDA,NEWIEN,ERR,DINUM
;F DINUM=+$P($G(^AUTTHF(0)),U,3):1:100000 Q:'$D(^AUTTHF(DINUM)) I DINUM>99999 D ERR^AUMSCBD("SYSTEM ERROR - DINUM FOR HEALTH FACTOR TOO BIG") Q
F DINUM=+$P($G(^AUTTHF(0)),U,3):1 Q:'$D(^AUTTHF(DINUM)) ;IHS/OIT/NKD AUM*18.0*1 REMOVED IEN RESTRICTION
;Q:DINUM>99999
S FDA(9999999.64,"+1,",.01)=P1
S FDA(9999999.64,"+1,",.03)=$S('P3A:DINUM,1:P3A)
S FDA(9999999.64,"+1,",.1)=P4
S NEWIEN(1)=DINUM
D UPDATE^DIE(,"FDA","NEWIEN","ERR")
I $D(ERR) D ERR^AUMSCBD("SYSTEM ERROR - New HEALTH FACTOR failed") Q
S AUMI=NEWIEN(1)
Q
; IHS/OIT/NKD AUM*18.0*2 - ADDED REVENUE CODES NEW
REVNEW ; EP - REVENUE CODES - CREATE REVENUE CODES ENTRY
N FDA,NEWIEN,ERR,DINUM
S FDA(9999999.72,"+1,",.01)=P1
S FDA(9999999.72,"+1,",1)=P2
S FDA(9999999.72,"+1,",2)=P7
S FDA(9999999.72,"+1,",3)=P3
S NEWIEN(1)=$S($G(AUMI):AUMI,1:P1A)
D UPDATE^DIE(,"FDA","NEWIEN","ERR")
I $D(ERR) D ERR^AUMSCBD("SYSTEM ERROR - New REVENUE CODES failed") Q
S AUMI=NEWIEN(1)
Q
; CUSTOM POST-ROUTINES
COMPOST ; EP - COMMUNITY - UPDATE PATIENT FILE CURRENT COMMUNITY IF NAME CHANGE
N CNT,CNT2,CNT3,AUMR
I $D(AUMD("DSP")) D DISP^AUMSCBD
;F CNT=1:1:$L(AUML,U) S AUMR=$P(AUML,U,CNT) Q:'AUMR D ; IHS/OIT/NKD AUM*14.0*3 - CORRECTED CONDITION
F CNT=1:1:$L(AUML,U) S AUMR=$P(AUML,U,CNT) Q:AUMR']"" D
. Q:$P(AUMR,"|",1)'="NAME"
. Q:$P(AUMR,"|",2)']"" ; IHS/OIT/NKD AUM*14.0*3 - CORRECTED CONDITION
. S (CNT2,CNT3)=0
. F S CNT2=$O(^AUPNPAT("AC",$P(AUMR,"|",2),CNT2)) Q:'CNT2 D
. . Q:$$COMMRES^AUPNPAT(CNT2)'=L1
. . N FDA,ERR
. . S FDA(9000001,CNT2_",",1118)=P4
. . D UPDATE^DIE(,"FDA",,"ERR")
. . S CNT3=CNT3+1
. I CNT3 D RSLT^AUMSCBD(" Updated "_CNT3_" PATIENT(s) Current Community due to COMMUNITY name change")
Q
EDTPOST ; EP - EDUCATION TOPIC - INACTIVATE LOCAL DUPLICATES
N FDA,CNT,CNT2,AUMR
I $D(AUMD("DSP")) D DISP^AUMSCBD
D FIND^DIC(9999999.09,"","@;.01;1;.06","PX",P1A,,"B","I ($P(^(0),U,3)'=1),(Y'=AUMI)",,"AUMR")
S CNT=$P($G(AUMR("DILIST",0)),U,1)
I CNT>0 D RSLT^AUMSCBD("Duplicate Names found") ; FOR : "_P3_$J("",13-$L(P3))_P2)
F CNT2=1:1:CNT D
. N L
. S L=$P(AUMR("DILIST",CNT2,0),U,3)_$J("",13-$L($P(AUMR("DILIST",CNT2,0),U,3)))_$P(AUMR("DILIST",CNT2,0),U,2)
. S FDA(9999999.09,$P(AUMR("DILIST",CNT2,0),U,1)_",",.03)="1" ; Inactive Flag (.03)
. D RSLT^AUMSCBD($J("",2)_"Local duplicate inactivated : "_L)
I CNT D UPDATE^DIE(,"FDA",)
K FDA,AUMR
D FIND^DIC(9999999.09,"","@;.01;1;.06","PX",P2A,,"C","I ($P(^(0),U,3)'=1),(Y'=AUMI)",,"AUMR")
S CNT=$P($G(AUMR("DILIST",0)),U,1)
I CNT>0 D RSLT^AUMSCBD("Duplicate Mnemonics found") ; FOR : "_P3_$J("",13-$L(P3))_P2)
F CNT2=1:1:CNT D
. N L
. S L=$P(AUMR("DILIST",CNT2,0),U,3)_$J("",13-$L($P(AUMR("DILIST",CNT2,0),U,3)))_$P(AUMR("DILIST",CNT2,0),U,2)
. S FDA(9999999.09,$P(AUMR("DILIST",CNT2,0),U,1)_",",.03)="1" ; Inactive Flag (.03)
. D RSLT^AUMSCBD($J("",2)_"Local duplicate inactivated : "_L)
I CNT D UPDATE^DIE(,"FDA",)
Q
LOCPOST ; EP - LOCATION - UPDATE INSTITUTION NAME
N FDA,ERR,AUMR,AUMI2
S AUMI2=$P(^AUTTLOC(AUMI,0),U,1)
I '$D(^DIC(4,AUMI2,0)) D ERR^AUMSCBD("INSTITUTION not found") Q
S AUMR=$$GET1^DIQ(4,AUMI2,.01,"I")
S FDA(4,AUMI2_",",.01)=P4
D UPDATE^DIE(,"FDA",,"ERR")
I $D(ERR) D ERR^AUMSCBD("SYSTEM ERROR - Update failed") Q
S:AUMR'=$$GET1^DIQ(4,AUMI2,.01,"I") AUMM=$S(AUMM']"":"MOD :",1:AUMM),AUML=AUML_"NAME|"_AUMR_"|"_P4_U
I $D(AUMD("DSP")) D DISP^AUMSCBD
Q
PSCPOST ; EP - PATIENT STATUS CODE - (TEMPORARY FIX) REMOVE INACTIVE FLAG IN OLD GLOBAL
I $D(AUMD("DSP")) D DISP^AUMSCBD
Q:'$D(^AUTPSC(AUMI,0))
;S $P(^AUTPSC(AUMI,0),U,3)="" ; IHS/OIT/NKD AUM*16.0*4 - INACTIVATE PROCESSING
S $P(^AUTPSC(AUMI,0),U,3)=$S(INA:1,1:"")
Q
PKLST ; EP - Check to see what EHR pick lists might be affected
N PKNAM,PK1,PK2,PK3,PXEDT,AUMDSP
D RSLT^AUMSCBD(""),RSLT^AUMSCBD("Displaying EHR PICKLISTS containing inactive EDUCATION TOPICS")
S PKNAM="",PK1=0
F S PK1=$O(^BGOEDTPR(PK1)) Q:PK1'?1N.N D
. S AUMDSP=1
. S PK2="" F S PK2=$O(^BGOEDTPR(PK1,PK2)) Q:PK2'?1N.N D
. . S:PK2=0 PKNAM=$P(^BGOEDTPR(PK1,PK2),U,1)
. . S PK3=0 F S PK3=$O(^BGOEDTPR(PK1,PK2,PK3)) Q:PK3'?1N.N D
. . . S PXEDT=$P($G(^BGOEDTPR(PK1,PK2,PK3,0)),U,1)
. . . Q:PXEDT=""
. . . Q:$P($G(^AUTTEDT(PXEDT,0)),U,3)'=1
. . . N AUMMNE,AUMNAM,AUMINA
. . . S AUMMNE=$P(^AUTTEDT(PXEDT,0),U,2),AUMNAM=$P(^AUTTEDT(PXEDT,0),U,1),AUMINA=$$FMTE^XLFDT($P(^AUTTEDT(PXEDT,0),U,5))
. . . I AUMDSP D RSLT^AUMSCBD(""),RSLT^AUMSCBD("Inactive topic(s) found in EHR PICKLIST: "_$P(^BGOEDTPR(PK1,0),U,1)) S AUMDSP=0
. . . D RSLT^AUMSCBD($J("",4)_AUMMNE_$J("",13-$L(AUMMNE))_"'"_$E(AUMNAM,1,47)_"'"_$J("",49-$L($E(AUMNAM,1,47)))_AUMINA)
. . . Q
. . Q
. Q
Q
; IHS/OIT/NKD AUM*15.0*3 - ADDED CLINIC REPORT
CLINIC ; EP - Check to see what HOSPITAL LOCATIONS might be affected by inactive CLINIC STOP codes
N STOP,DATE,CLINIC,RES
D RSLT^AUMSCBD(""),RSLT^AUMSCBD(" The following report displays CLINIC STOP file (#40.7) entries next to their")
D RSLT^AUMSCBD("inactivation date. Appropriate measures should be taken to review this list and")
D RSLT^AUMSCBD("make any necessary local modifications. For example, if visits are created using")
D RSLT^AUMSCBD("inactive CLINIC STOP codes, it might require a review of the CLINIC STOP field")
D RSLT^AUMSCBD("in the HOSPITAL LOCATION file (#44). This particular scenario is included in the")
D RSLT^AUMSCBD("report and displays after each CLINIC STOP code.")
D RSLT^AUMSCBD(""),RSLT^AUMSCBD("*** This report also runs at the programmer prompt with: D CLINIC^AUMSCBU ***")
D RSLT^AUMSCBD(""),RSLT^AUMSCBD(" CODE NAME (INACTIVATION DATE)")
D RSLT^AUMSCBD(" HOSPITAL LOCATION - DIVISION (IEN)")
D RSLT^AUMSCBD(" ==== ========================")
S STOP=0 F S STOP=$O(^DIC(40.7,STOP)) Q:'STOP D
. S DATE=$$GET1^DIQ(40.7,STOP,2,"I") Q:'DATE
. S RES=$J("",7)_$$GET1^DIQ(40.7,STOP,1,"I"),$E(RES,13,80)=$$GET1^DIQ(40.7,STOP,.01,"I")_" ("_$$FMTE^XLFDT(DATE,5)_")"
. D RSLT^AUMSCBD(RES)
. S CLINIC=0 F S CLINIC=$O(^SC("ASTOP",STOP,CLINIC)) Q:'CLINIC D
. . Q:$P($G(^SC(CLINIC,0)),U,7)'=STOP Q:$$GET1^DIQ(44,CLINIC,2,"I")'="C"
. . Q:$S($P($G(^SC(CLINIC,"I")),U)="":1,$P(^("I"),U)>DATE:1,$P(^("I"),U,2)="":0,$P(^("I"),U,2)'>DATE:1,1:0)
. . S RES=$J("",14)_$$GET1^DIQ(44,CLINIC,.01,"I")_" - "_$$GET1^DIQ(44,CLINIC,3)_" (IEN "_CLINIC_")"
. . D RSLT^AUMSCBD(RES)
Q
AUMSCBU ;IHS/OIT/NKD - SCB UPDATE - UTILITY 12/07/2012 ;
+1 ;;19.0;TABLE MAINTENANCE;**1**;SEP 04,2018;Build 1
+2 ; 03/12/14 - Modified Inactivate processing for Education tables
+3 ; 05/28/14 - Added Tribe pre-routine for Inactivate processing
+4 ; - Corrected condition to trigger Patient Current Community change
+5 ; 12/16/14 - Removed old/unused code
+6 ; 05/29/15 - Added Clinic Stop Inactivate processing
+7 ; - Added Clinic report
+8 ; 12/22/15 - Added Health Factor tag for New processing
+9 ; 08/22/16 - Modified Inactivate processing for Patient Status Code
+10 ; 12/04/17 - Removed Health Factor IEN restriction
+11 ; 03/15/18 - Added Revenue Codes table Pre and New processing
+12 ;
+13 QUIT
+14 ; CUSTOM PRE-ROUTINES
CNTYPRE ; EP - COUNTY - INPUT TRANSFORMS
+1 SET L1=P1_P2
+2 IF P1]""
SET P1A=$ORDER(^DIC(5,"C",P1,0))
+3 SET P7=$SELECT(P7]"":P7-17000000,1:"")
+4 IF P7]""
SET AUMA="INA"
SET INA=1
+5 IF 'P1A
IF 'INA
DO ERR^AUMSCBD("Invalid STATE code: "_P1)
+6 QUIT
COMPRE ; EP - COMMUNITY - INPUT TRANSFORMS
+1 NEW CNT,TEXT,AUMR
+2 SET L1=P1_P2_P3
+3 IF P1]""
SET P1A=$ORDER(^DIC(5,"C",P1,0))
+4 KILL AUMR
FOR CNT=1:1
SET TEXT=$PIECE($TEXT(CNTY+CNT^AUMSCBM),";;",2)
IF TEXT="END"
QUIT
IF TEXT="SEA"
SET AUMR=$PIECE($TEXT(CNTY+CNT^AUMSCBM),";;",3)
+5 IF $DATA(AUMR)
Begin DoDot:1
+6 NEW L1
+7 SET L1=P1_P2
+8 IF P2]""
SET P2A=$$SEARCH^AUMSCBD(AUMR)
End DoDot:1
+9 IF P5]""
SET P5A=$ORDER(^AUTTAREA("C",P5,0))
+10 KILL AUMR
FOR CNT=1:1
SET TEXT=$PIECE($TEXT(SU+CNT^AUMSCBM),";;",2)
IF TEXT="END"
QUIT
IF TEXT="SEA"
SET AUMR=$PIECE($TEXT(SU+CNT^AUMSCBM),";;",3)
+11 IF $DATA(AUMR)
Begin DoDot:1
+12 NEW L1
+13 SET L1=P5_P6
+14 IF P6]""
SET P6A=$$SEARCH^AUMSCBD(AUMR)
End DoDot:1
+15 SET P7=$SELECT(P7]"":P7-17000000,1:"")
+16 IF P7]""
SET AUMA="INA"
SET INA=1
+17 IF 'P1A
IF 'INA
DO ERR^AUMSCBD("Invalid STATE code: "_P1)
+18 IF 'P2A
IF 'INA
DO ERR^AUMSCBD("Invalid COUNTY code: "_P1_P2)
+19 IF 'P5A
IF 'INA
DO ERR^AUMSCBD("Invalid AREA code: "_P5)
+20 IF 'P6A
IF 'INA
DO ERR^AUMSCBD("Invalid SERVICE UNIT code: "_P5_P6)
+21 QUIT
EDTPRE ; EP - EDUCATION TOPIC - INPUT TRANSFORMS AND LOOKUP
+1 NEW CNT,AUMR
+2 ; IHS/OIT/NKD AUM*14.0*2
SET P1=$$CLEAN^AUMSCBD(P1)
SET P2=$$CLEAN^AUMSCBD(P2)
SET P3=$$CLEAN^AUMSCBD(P3)
SET P7=$SELECT(P7]"":P7-17000000,1:"")
+3 SET P1A=P3_"-"_P1
SET P2A=P3_"-"_P2
SET P3A=$ORDER(^AUTTEDMT("B",P3,0))
+4 ; IHS/OIT/NKD AUM*14.0*2
IF P7]""
SET AUMA="INA"
SET INA=1
+5 DO FIND^DIC(9999999.09,"","@;.01","PX",P1A,,"B",,,"AUMR")
+6 SET CNT=$PIECE($GET(AUMR("DILIST",0)),U,1)
+7 SET AUMI=$SELECT(CNT=1:$PIECE($GET(AUMR("DILIST",1,0)),U,1),CNT>1:$PIECE($GET(AUMR("DILIST",$PIECE($GET(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
+8 IF 'AUMI
Begin DoDot:1
+9 KILL AUMR
+10 DO FIND^DIC(9999999.09,"","@;.01","PX",P2A,,"C","I ($P(^(0),U,3)'=1),($P(^(0),U)=$$UP^XLFSTR($P(^(0),U)))",,"AUMR")
+11 SET CNT=$PIECE($GET(AUMR("DILIST",0)),U,1)
+12 SET AUMI=$SELECT(CNT=1:$PIECE($GET(AUMR("DILIST",1,0)),U,1),CNT>1:$PIECE($GET(AUMR("DILIST",$PIECE($GET(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
End DoDot:1
+13 QUIT
LOCPRE ; EP - LOCATION - INPUT TRANSFORMS
+1 NEW CNT,TEXT,AUMR
+2 SET L1=P1_P2_P3
+3 IF P1]""
SET P1A=$ORDER(^AUTTAREA("C",P1,0))
+4 FOR CNT=1:1
SET TEXT=$PIECE($TEXT(SU+CNT^AUMSCBM),";;",2)
IF TEXT="END"
QUIT
IF TEXT="SEA"
SET AUMR=$PIECE($TEXT(SU+CNT^AUMSCBM),";;",3)
+5 IF $DATA(AUMR)
Begin DoDot:1
+6 NEW L1
+7 SET L1=P1_P2
+8 IF P2]""
SET P2A=$$SEARCH^AUMSCBD(AUMR)
End DoDot:1
+9 SET P7=$SELECT(P7]"":P7-17000000,1:"")
+10 IF P7]""
SET AUMA="INA"
SET INA=1
+11 IF 'P1A
IF 'INA
DO ERR^AUMSCBD("Invalid AREA code: "_P1)
+12 IF 'P2A
IF 'INA
DO ERR^AUMSCBD("Invalid SERVICE UNIT code: "_P1_P2)
+13 QUIT
MEASPRE ; EP - MEASUREMENT TYPE - INPUT TRANSFORMS
+1 SET P6=$TRANSLATE(P6,"|",U)
+2 QUIT
MJTPRE ; EP - EDUCATION MAJOR TOPIC - INPUT TRANSFORMS
+1 ; IHS/OIT/NKD AUM*14.0*2
SET P1=$$CLEAN^AUMSCBD(P1)
SET P2=$$CLEAN^AUMSCBD(P2)
SET P7=$SELECT(P7]"":P7-17000000,1:"")
+2 ; IHS/OIT/NKD AUM*14.0*2
IF P7]""
SET AUMA="INA"
SET INA=1
+3 QUIT
RESPRE ; EP - RESERVATION - INPUT TRANSFORMS
+1 IF P3]""
SET P3A=$ORDER(^AUTTAREA("C",P3,0))
+2 IF P4]""
SET P4A=$ORDER(^DIC(5,"C",P4,0))
+3 IF 'P3A
IF 'INA
DO ERR^AUMSCBD("Invalid AREA code: "_P3)
+4 IF 'P4A
IF 'INA
DO ERR^AUMSCBD("Invalid STATE code: "_P4)
+5 QUIT
STNMPRE ; EP - STATION NUMBER - INPUT TRANSFORMS AND LOOKUP
+1 IF P2]""
SET P2A=$ORDER(^AUTTLOC("C",P2,0))
+2 IF 'P2A&INA
QUIT
+3 IF 'P2A
DO ERR^AUMSCBD("LOCATION not found: "_P2)
QUIT
+4 IF '$DATA(^DIC(4,P2A,0))&INA
QUIT
+5 IF '$DATA(^DIC(4,P2A,0))
DO ERR^AUMSCBD("INSTITUTION not found: "_P2)
QUIT
+6 SET AUMI=P2A
+7 QUIT
SUPRE ; EP - SERVICE UNIT - INPUT TRANSFORMS
+1 SET L1=P1_P2
+2 IF P1]""
SET P1A=$ORDER(^AUTTAREA("C",P1,0))
+3 SET P7=$SELECT(P7]"":P7-17000000,1:"")
+4 IF P7]""
SET AUMA="INA"
SET INA=1
+5 IF 'P1A
IF 'INA
DO ERR^AUMSCBD("Invalid AREA code: "_P1)
+6 QUIT
STPRE ; EP - STATE - LOOKUP
+1 NEW CNT,AUMR
+2 SET P7=$SELECT(P7]"":P7-17000000,1:"")
+3 IF P7]""
SET AUMA="INA"
SET INA=1
+4 DO FIND^DIC(5,"","@;.01","PX",P1,,"B",,,"AUMR")
+5 SET CNT=$PIECE($GET(AUMR("DILIST",0)),U,1)
+6 SET AUMI=$SELECT(CNT=1:$PIECE($GET(AUMR("DILIST",1,0)),U,1),CNT>1:$PIECE($GET(AUMR("DILIST",$PIECE($GET(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
+7 IF 'AUMI
Begin DoDot:1
+8 KILL AUMR
+9 ; SCREEN TO REMOVE ENTRIES THAT DON'T MATCH
DO FIND^DIC(5,"","@;.01","PX",P3,,"C","I $P(^(0),U,3)=P3",,"AUMR")
+10 SET CNT=$PIECE($GET(AUMR("DILIST",0)),U,1)
+11 SET AUMI=$SELECT(CNT=1:$PIECE($GET(AUMR("DILIST",1,0)),U,1),CNT>1:$PIECE($GET(AUMR("DILIST",$PIECE($GET(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
End DoDot:1
+12 QUIT
HFPRE ; EP - HEALTH FACTOR - INPUT TRANSFORMS
+1 NEW CNT,AUMR
+2 ; SEARCH FOR ACTIVE CATEGORIES MATCHING NAME
+3 DO FIND^DIC(9999999.64,"","@;.01","PX",P3,,"B","I $P(^(0),U,10)'=""F"",$P(^(0),U,13)'=""1""",,"AUMR")
+4 SET CNT=$PIECE($GET(AUMR("DILIST",0)),U,1)
+5 SET P3A=$SELECT(CNT=1:$PIECE($GET(AUMR("DILIST",1,0)),U,1),CNT>1:$PIECE($GET(AUMR("DILIST",$PIECE($GET(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
+6 ; IF NO MATCHES FOUND, SEARCH FOR CATEGORIES MATCHING NAME
+7 IF 'P3A
Begin DoDot:1
+8 KILL AUMR
+9 DO FIND^DIC(9999999.64,"","@;.01","PX",P3,,"B","I $P(^(0),U,10)'=""F""",,"AUMR")
+10 SET CNT=$PIECE($GET(AUMR("DILIST",0)),U,1)
+11 SET P3A=$SELECT(CNT=1:$PIECE($GET(AUMR("DILIST",1,0)),U,1),CNT>1:$PIECE($GET(AUMR("DILIST",$PIECE($GET(AUMR("DILIST",0)),U,1),0)),U,1),1:"")
End DoDot:1
+12 ;I 'P3A,'INA D ERR^AUMSCBD("Invalid CATEGORY code: "_P3) ; IHS/OIT/NKD AUM*16.0*1 - LOGIC CHANGE FOR HF CATEGORY CREATION
+13 IF 'P3A
IF 'INA
IF P4'="C"
DO ERR^AUMSCBD("Invalid CATEGORY code: "_P3)
+14 QUIT
LANGPRE ; EP - LANGUAGES - INPUT TRANSFORMS
+1 SET P2=$$UP^XLFSTR(P2)
SET P3=$$UP^XLFSTR(P3)
+2 QUIT
PSCPRE ; EP - PATIENT STATUS CODE - INPUT TRANSFORMS
+1 SET P1A=P1_" "
+2 ; IHS/OIT/NKD AUM*16.0*4 - INACTIVATE PROCESSING
IF P4]""
SET AUMA="INA"
SET INA=1
+3 QUIT
AREAPRE ; EP - AREA - INPUT TRANSFORMS
+1 SET P7=$SELECT(P7]"":P7-17000000,1:"")
+2 IF P7]""
SET AUMA="INA"
SET INA=1
+3 QUIT
CLINPRE ; EP - CLINIC STOP - INPUT TRANSFORMS
+1 SET P4A=$SELECT(P4="Y":ONE,P4="N":AT,1:"")
+2 ; IHS/OIT/NKD AUM*15.0*3 - INACTIVATE PROCESSING
SET P7=$SELECT(P7]"":P7-17000000,1:"")
+3 IF P7]""
SET AUMA="INA"
SET INA=1
SET P2="x"_P2
+4 QUIT
+5 ; IHS/OIT/NKD AUM*14.0*3 - ADDED TRIBE PRE
TRIPRE ; EP - TRIBE - INPUT TRANSFORMS
+1 SET P7=$SELECT(P7]"":"Y",1:"")
+2 IF P7]""
SET AUMA="INA"
SET INA=1
+3 QUIT
+4 ; IHS/OIT/NKD AUM*18.0*2 - ADDED REVENUE CODES PRE
REVPRE ; EP - REVENUE CODES - CREATE REVENUE CODES ENTRY
+1 SET P1A=+P1
IF P1A
SET AUMI=$SELECT($DATA(^AUTTREVN(P1A)):P1A,1:0)
+2 IF P7
SET AUMA="INA"
SET INA=1
+3 QUIT
+4 ; CUSTOM NEW-ROUTINES
LOCNEW ; EP - LOCATION - CREATE INSTITUTION AND LOCATION ENTRIES
+1 NEW FDA,NEWIEN,ERR,DINUM
+2 FOR DINUM=+$PIECE(^DIC(4,0),U,3):1
IF '$DATA(^DIC(4,DINUM))&('$DATA(^AUTTLOC(DINUM)))
QUIT
IF DINUM>99999
DO ERR^AUMSCBD("SYSTEM ERROR - DINUM FOR LOC/INSTITUTION TOO BIG")
QUIT
+3 IF DINUM>99999
QUIT
+4 SET FDA(4,"+1,",.01)=P4
+5 SET NEWIEN(1)=DINUM
+6 DO UPDATE^DIE(,"FDA","NEWIEN","ERR")
+7 IF $DATA(ERR)
DO ERR^AUMSCBD("SYSTEM ERROR - New INSTITUTION failed")
QUIT
+8 SET AUMI=NEWIEN(1)
+9 IF '$DATA(^AUTTLOC(AUMI))
Begin DoDot:1
+10 KILL FDA,NEWIEN,ERR
+11 SET FDA(9999999.06,"+1,",.01)=AUMI
+12 SET FDA(9999999.06,"+1,",.04)=P1A
+13 SET FDA(9999999.06,"+1,",.07)=P3
+14 SET FDA(9999999.06,"+1,",.32)=P6
+15 SET NEWIEN(1)=AUMI
+16 DO UPDATE^DIE(,"FDA","NEWIEN","ERR")
+17 IF $DATA(ERR)
DO ERR^AUMSCBD("SYSTEM ERROR - New LOCATION failed")
QUIT
+18 IF AUMI'=NEWIEN(1)
DO ERR^AUMSCBD("SYSTEM ERROR - INSTITUTION/LOCATION IEN mismatch")
QUIT
End DoDot:1
+19 QUIT
+20 ; IHS/OIT/NKD AUM*16.0*1 - ADDED HEALTH FACTORS NEW
HFNEW ; EP - HEALTH FACTORS - CREATE HEALTH FACTOR ENTRY
+1 NEW FDA,NEWIEN,ERR,DINUM
+2 ;F DINUM=+$P($G(^AUTTHF(0)),U,3):1:100000 Q:'$D(^AUTTHF(DINUM)) I DINUM>99999 D ERR^AUMSCBD("SYSTEM ERROR - DINUM FOR HEALTH FACTOR TOO BIG") Q
+3 ;IHS/OIT/NKD AUM*18.0*1 REMOVED IEN RESTRICTION
FOR DINUM=+$PIECE($GET(^AUTTHF(0)),U,3):1
IF '$DATA(^AUTTHF(DINUM))
QUIT
+4 ;Q:DINUM>99999
+5 SET FDA(9999999.64,"+1,",.01)=P1
+6 SET FDA(9999999.64,"+1,",.03)=$SELECT('P3A:DINUM,1:P3A)
+7 SET FDA(9999999.64,"+1,",.1)=P4
+8 SET NEWIEN(1)=DINUM
+9 DO UPDATE^DIE(,"FDA","NEWIEN","ERR")
+10 IF $DATA(ERR)
DO ERR^AUMSCBD("SYSTEM ERROR - New HEALTH FACTOR failed")
QUIT
+11 SET AUMI=NEWIEN(1)
+12 QUIT
+13 ; IHS/OIT/NKD AUM*18.0*2 - ADDED REVENUE CODES NEW
REVNEW ; EP - REVENUE CODES - CREATE REVENUE CODES ENTRY
+1 NEW FDA,NEWIEN,ERR,DINUM
+2 SET FDA(9999999.72,"+1,",.01)=P1
+3 SET FDA(9999999.72,"+1,",1)=P2
+4 SET FDA(9999999.72,"+1,",2)=P7
+5 SET FDA(9999999.72,"+1,",3)=P3
+6 SET NEWIEN(1)=$SELECT($GET(AUMI):AUMI,1:P1A)
+7 DO UPDATE^DIE(,"FDA","NEWIEN","ERR")
+8 IF $DATA(ERR)
DO ERR^AUMSCBD("SYSTEM ERROR - New REVENUE CODES failed")
QUIT
+9 SET AUMI=NEWIEN(1)
+10 QUIT
+11 ; CUSTOM POST-ROUTINES
COMPOST ; EP - COMMUNITY - UPDATE PATIENT FILE CURRENT COMMUNITY IF NAME CHANGE
+1 NEW CNT,CNT2,CNT3,AUMR
+2 IF $DATA(AUMD("DSP"))
DO DISP^AUMSCBD
+3 ;F CNT=1:1:$L(AUML,U) S AUMR=$P(AUML,U,CNT) Q:'AUMR D ; IHS/OIT/NKD AUM*14.0*3 - CORRECTED CONDITION
+4 FOR CNT=1:1:$LENGTH(AUML,U)
SET AUMR=$PIECE(AUML,U,CNT)
IF AUMR']""
QUIT
Begin DoDot:1
+5 IF $PIECE(AUMR,"|",1)'="NAME"
QUIT
+6 ; IHS/OIT/NKD AUM*14.0*3 - CORRECTED CONDITION
IF $PIECE(AUMR,"|",2)']""
QUIT
+7 SET (CNT2,CNT3)=0
+8 FOR
SET CNT2=$ORDER(^AUPNPAT("AC",$PIECE(AUMR,"|",2),CNT2))
IF 'CNT2
QUIT
Begin DoDot:2
+9 IF $$COMMRES^AUPNPAT(CNT2)'=L1
QUIT
+10 NEW FDA,ERR
+11 SET FDA(9000001,CNT2_",",1118)=P4
+12 DO UPDATE^DIE(,"FDA",,"ERR")
+13 SET CNT3=CNT3+1
End DoDot:2
+14 IF CNT3
DO RSLT^AUMSCBD(" Updated "_CNT3_" PATIENT(s) Current Community due to COMMUNITY name change")
End DoDot:1
+15 QUIT
EDTPOST ; EP - EDUCATION TOPIC - INACTIVATE LOCAL DUPLICATES
+1 NEW FDA,CNT,CNT2,AUMR
+2 IF $DATA(AUMD("DSP"))
DO DISP^AUMSCBD
+3 DO FIND^DIC(9999999.09,"","@;.01;1;.06","PX",P1A,,"B","I ($P(^(0),U,3)'=1),(Y'=AUMI)",,"AUMR")
+4 SET CNT=$PIECE($GET(AUMR("DILIST",0)),U,1)
+5 ; FOR : "_P3_$J("",13-$L(P3))_P2)
IF CNT>0
DO RSLT^AUMSCBD("Duplicate Names found")
+6 FOR CNT2=1:1:CNT
Begin DoDot:1
+7 NEW L
+8 SET L=$PIECE(AUMR("DILIST",CNT2,0),U,3)_$JUSTIFY("",13-$LENGTH($PIECE(AUMR("DILIST",CNT2,0),U,3)))_$PIECE(AUMR("DILIST",CNT2,0),U,2)
+9 ; Inactive Flag (.03)
SET FDA(9999999.09,$PIECE(AUMR("DILIST",CNT2,0),U,1)_",",.03)="1"
+10 DO RSLT^AUMSCBD($JUSTIFY("",2)_"Local duplicate inactivated : "_L)
End DoDot:1
+11 IF CNT
DO UPDATE^DIE(,"FDA",)
+12 KILL FDA,AUMR
+13 DO FIND^DIC(9999999.09,"","@;.01;1;.06","PX",P2A,,"C","I ($P(^(0),U,3)'=1),(Y'=AUMI)",,"AUMR")
+14 SET CNT=$PIECE($GET(AUMR("DILIST",0)),U,1)
+15 ; FOR : "_P3_$J("",13-$L(P3))_P2)
IF CNT>0
DO RSLT^AUMSCBD("Duplicate Mnemonics found")
+16 FOR CNT2=1:1:CNT
Begin DoDot:1
+17 NEW L
+18 SET L=$PIECE(AUMR("DILIST",CNT2,0),U,3)_$JUSTIFY("",13-$LENGTH($PIECE(AUMR("DILIST",CNT2,0),U,3)))_$PIECE(AUMR("DILIST",CNT2,0),U,2)
+19 ; Inactive Flag (.03)
SET FDA(9999999.09,$PIECE(AUMR("DILIST",CNT2,0),U,1)_",",.03)="1"
+20 DO RSLT^AUMSCBD($JUSTIFY("",2)_"Local duplicate inactivated : "_L)
End DoDot:1
+21 IF CNT
DO UPDATE^DIE(,"FDA",)
+22 QUIT
LOCPOST ; EP - LOCATION - UPDATE INSTITUTION NAME
+1 NEW FDA,ERR,AUMR,AUMI2
+2 SET AUMI2=$PIECE(^AUTTLOC(AUMI,0),U,1)
+3 IF '$DATA(^DIC(4,AUMI2,0))
DO ERR^AUMSCBD("INSTITUTION not found")
QUIT
+4 SET AUMR=$$GET1^DIQ(4,AUMI2,.01,"I")
+5 SET FDA(4,AUMI2_",",.01)=P4
+6 DO UPDATE^DIE(,"FDA",,"ERR")
+7 IF $DATA(ERR)
DO ERR^AUMSCBD("SYSTEM ERROR - Update failed")
QUIT
+8 IF AUMR'=$$GET1^DIQ(4,AUMI2,.01,"I")
SET AUMM=$SELECT(AUMM']"":"MOD :",1:AUMM)
SET AUML=AUML_"NAME|"_AUMR_"|"_P4_U
+9 IF $DATA(AUMD("DSP"))
DO DISP^AUMSCBD
+10 QUIT
PSCPOST ; EP - PATIENT STATUS CODE - (TEMPORARY FIX) REMOVE INACTIVE FLAG IN OLD GLOBAL
+1 IF $DATA(AUMD("DSP"))
DO DISP^AUMSCBD
+2 IF '$DATA(^AUTPSC(AUMI,0))
QUIT
+3 ;S $P(^AUTPSC(AUMI,0),U,3)="" ; IHS/OIT/NKD AUM*16.0*4 - INACTIVATE PROCESSING
+4 SET $PIECE(^AUTPSC(AUMI,0),U,3)=$SELECT(INA:1,1:"")
+5 QUIT
PKLST ; EP - Check to see what EHR pick lists might be affected
+1 NEW PKNAM,PK1,PK2,PK3,PXEDT,AUMDSP
+2 DO RSLT^AUMSCBD("")
DO RSLT^AUMSCBD("Displaying EHR PICKLISTS containing inactive EDUCATION TOPICS")
+3 SET PKNAM=""
SET PK1=0
+4 FOR
SET PK1=$ORDER(^BGOEDTPR(PK1))
IF PK1'?1N.N
QUIT
Begin DoDot:1
+5 SET AUMDSP=1
+6 SET PK2=""
FOR
SET PK2=$ORDER(^BGOEDTPR(PK1,PK2))
IF PK2'?1N.N
QUIT
Begin DoDot:2
+7 IF PK2=0
SET PKNAM=$PIECE(^BGOEDTPR(PK1,PK2),U,1)
+8 SET PK3=0
FOR
SET PK3=$ORDER(^BGOEDTPR(PK1,PK2,PK3))
IF PK3'?1N.N
QUIT
Begin DoDot:3
+9 SET PXEDT=$PIECE($GET(^BGOEDTPR(PK1,PK2,PK3,0)),U,1)
+10 IF PXEDT=""
QUIT
+11 IF $PIECE($GET(^AUTTEDT(PXEDT,0)),U,3)'=1
QUIT
+12 NEW AUMMNE,AUMNAM,AUMINA
+13 SET AUMMNE=$PIECE(^AUTTEDT(PXEDT,0),U,2)
SET AUMNAM=$PIECE(^AUTTEDT(PXEDT,0),U,1)
SET AUMINA=$$FMTE^XLFDT($PIECE(^AUTTEDT(PXEDT,0),U,5))
+14 IF AUMDSP
DO RSLT^AUMSCBD("")
DO RSLT^AUMSCBD("Inactive topic(s) found in EHR PICKLIST: "_$PIECE(^BGOEDTPR(PK1,0),U,1))
SET AUMDSP=0
+15 DO RSLT^AUMSCBD($JUSTIFY("",4)_AUMMNE_$JUSTIFY("",13-$LENGTH(AUMMNE))_"'"_$EXTRACT(AUMNAM,1,47)_"'"_$JUSTIFY("",49-$LENGTH($EXTRACT(AUMNAM,1,47)))_AUMINA)
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT
+20 ; IHS/OIT/NKD AUM*15.0*3 - ADDED CLINIC REPORT
CLINIC ; EP - Check to see what HOSPITAL LOCATIONS might be affected by inactive CLINIC STOP codes
+1 NEW STOP,DATE,CLINIC,RES
+2 DO RSLT^AUMSCBD("")
DO RSLT^AUMSCBD(" The following report displays CLINIC STOP file (#40.7) entries next to their")
+3 DO RSLT^AUMSCBD("inactivation date. Appropriate measures should be taken to review this list and")
+4 DO RSLT^AUMSCBD("make any necessary local modifications. For example, if visits are created using")
+5 DO RSLT^AUMSCBD("inactive CLINIC STOP codes, it might require a review of the CLINIC STOP field")
+6 DO RSLT^AUMSCBD("in the HOSPITAL LOCATION file (#44). This particular scenario is included in the")
+7 DO RSLT^AUMSCBD("report and displays after each CLINIC STOP code.")
+8 DO RSLT^AUMSCBD("")
DO RSLT^AUMSCBD("*** This report also runs at the programmer prompt with: D CLINIC^AUMSCBU ***")
+9 DO RSLT^AUMSCBD("")
DO RSLT^AUMSCBD(" CODE NAME (INACTIVATION DATE)")
+10 DO RSLT^AUMSCBD(" HOSPITAL LOCATION - DIVISION (IEN)")
+11 DO RSLT^AUMSCBD(" ==== ========================")
+12 SET STOP=0
FOR
SET STOP=$ORDER(^DIC(40.7,STOP))
IF 'STOP
QUIT
Begin DoDot:1
+13 SET DATE=$$GET1^DIQ(40.7,STOP,2,"I")
IF 'DATE
QUIT
+14 SET RES=$JUSTIFY("",7)_$$GET1^DIQ(40.7,STOP,1,"I")
SET $EXTRACT(RES,13,80)=$$GET1^DIQ(40.7,STOP,.01,"I")_" ("_$$FMTE^XLFDT(DATE,5)_")"
+15 DO RSLT^AUMSCBD(RES)
+16 SET CLINIC=0
FOR
SET CLINIC=$ORDER(^SC("ASTOP",STOP,CLINIC))
IF 'CLINIC
QUIT
Begin DoDot:2
+17 IF $PIECE($GET(^SC(CLINIC,0)),U,7)'=STOP
QUIT
IF $$GET1^DIQ(44,CLINIC,2,"I")'="C"
QUIT
+18 IF $SELECT($PIECE($GET(^SC(CLINIC,"I")),U)=""
QUIT
+19 SET RES=$JUSTIFY("",14)_$$GET1^DIQ(44,CLINIC,.01,"I")_" - "_$$GET1^DIQ(44,CLINIC,3)_" (IEN "_CLINIC_")"
+20 DO RSLT^AUMSCBD(RES)
End DoDot:2
End DoDot:1
+21 QUIT
