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

AUMSCBU.m

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