- AG71A9 ;VNGT/HS/BEE - Patient Registration 7.1 PATCH 9 POST INSTALL ; MAY 07, 2010
- ;;7.1;PATIENT REGISTRATION;**9**;AUG 25, 2005
- ;
- Q
- ;
- POST ;EP - From KIDS.
- ;
- N CLBEN,MMSG,IEN,AMIND
- D TS,BMES^XPDUTL("Beginning post-install routine (POST^AG71A9).")
- ;
- S MMSG=" --- AG v 7.1 Patch 9 has been installed into this uci --- "
- ;
- ;Set new 'LINK AOB TO ROI FIELD' to default of 'NO'
- ;and define new facility parameter ROI/AOB required prompts
- W !
- S IEN=0 F S IEN=$O(^AGFAC(IEN)) Q:'IEN D
- . ;
- . ;Set up new ETHNICITY INFORMATION Required registration parameter prompt
- . D ETHN^AG71A9(IEN)
- . ;
- . ;Set up new RACE Required registration parameter prompt
- . D RACE^AG71A9(IEN)
- . ;
- . ;Set up new PREFERRED LANGUAGE Required registration parameter prompt
- . D PREF^AG71A9(IEN)
- . ;
- . ;Set up new PRIMARY LANGUAGE Required registration parameter prompt
- . D PRIM^AG71A9(IEN)
- . ;
- . ;Set up Homeless and Migrant prompts with default of no
- . D HOM^AG71A9(IEN)
- ;
- ;Remove the lock from the AGSETSITE option
- N DIC,X,Y S DIC="^DIC(19,",X="AGSETSITE"
- D ^DIC
- I +Y>0 D
- . N DA,DIC,DIE,DR,X
- . S DA=+Y
- . S DIE="^DIC(19,"
- . S DR="3////@"
- . D ^DIE
- K DIC,X,Y
- ;
- ;Populate Race field based on CLASSIFICATION/BENEFICIARY
- D TS,BMES^XPDUTL("AutoPopulating PATIENT RACE field (POST^AG71A9).")
- S CLBEN=$O(^AUTTBEN("B","INDIAN/ALASKA NATIVE","")) ;Get Classification IEN
- S AMIND=$O(^DIC(10,"B","AMERICAN INDIAN OR ALASKA NATIVE","")) ;Get Amer/Ind IEN
- ;
- I CLBEN]"",AMIND]"" D
- . N DFN,X,ERROR
- . S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN D
- .. ;
- .. ;Quit if CLASSIFICATION/BENEFICIARY not equal to INDIAN/ALASKA NATIVE
- .. Q:$$GET1^DIQ(9000001,DFN_",",1111,"I")'=CLBEN
- .. ;
- .. ;Update RACE
- .. K DA,DIC,X,Y
- .. N DA,DIE,DR
- .. S DA=DFN
- .. S DIE="^DPT("
- .. S DR=".06////"_AMIND
- .. D ^DIE
- ;
- D TS,BMES^XPDUTL("Delivering v 7.1 Patch 9 install message to select users...")
- ;
- ;Deliver Mail Message
- D MAIL(MMSG)
- ;
- D TS,BMES^XPDUTL("AG v 7.1 Patch 9 Post-install is complete.")
- Q
- ;
- MAIL(MMSG) ;Send install mail message.
- N %,CNT,DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
- K ^TMP("AG71MS",$J)
- S ^TMP("AG71MS",$J,1)=$G(MMSG)
- S ^TMP("AG71MS",$J,2)=" "
- S CNT=3
- ;
- S %=0
- Q:$G(XPDA)=""
- Q:$G(XPDBLD)=""
- 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
- ;
- TS D MES^XPDUTL($$HTE^XLFDT($H)) Q
- ;
- HOM(FAC) ;Set Homeless and Migrant Display parameters
- ;
- N VAL
- ;
- ;Homeless Display
- S VAL=$$GET1^DIQ(9009061,FAC_",",28) I VAL="" D
- . ;
- . ;Set the display to "YES"
- . K DA,DIC,X,Y
- . N DA,DIE,DR
- . S DA=FAC
- . S DIE="^AGFAC("
- . S DR="28////Y"
- . D ^DIE
- ;
- ;Migrant Display
- S VAL=$$GET1^DIQ(9009061,FAC_",",27) I VAL="" D
- . ;
- . ;Set the display to "YES"
- . K DA,DIC,X,Y
- . N DA,DIE,DR
- . S DA=FAC
- . S DIE="^AGFAC("
- . S DR="27////Y"
- . D ^DIE
- ;
- Q
- ;
- ETHN(FAC) ;Now add the ETHNICITY field
- ;
- N PRFIEN,DA,DIC,FLIEN,X,Y
- ;
- ;First Look for existing 2 entry
- S DA(1)=FAC
- S DIC="^AGFAC("_FAC_",11,"
- S DIC(0)="L"
- S X="2"
- D ^DIC
- Q:Y'>0
- S FLIEN=+Y
- ;
- ;Quit if ETHNICITY INFORMATION already defined
- I $O(^AGFAC(FAC,11,FLIEN,1,"B","ETHNICITY INFORMATION",""))]"" Q
- ;
- ;Now add the ETHNICITY field
- W !
- K DA,DIE,DR
- N DA,DIC,X,Y
- S DA(2)=FAC,DA(1)=FLIEN
- S DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- S DIC(0)="LS"
- S X="6"
- D ^DIC
- S PRFIEN=+Y
- I +PRFIEN W " REQUIRED? parameter added for site: ",$$GET1^DIQ(9999999.06,FAC_",",.01,"E")
- ;
- ;Set the required value to NO
- K DA,DIC,X,Y
- N DA,DIE,DR
- S DA(2)=FAC,DA(1)=FLIEN,DA=PRFIEN
- S DIE="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- S DR=".02////0"
- D ^DIE
- Q
- ;
- RACE(FAC) ;Now add the RACE field
- ;
- N PRFIEN,DA,DIC,FLIEN,X,Y
- ;
- ;First Look for existing 2 entry
- S DA(1)=FAC
- S DIC="^AGFAC("_FAC_",11,"
- S DIC(0)="L"
- S X="2"
- D ^DIC
- Q:Y'>0
- S FLIEN=+Y
- ;
- ;Quit if RACE already defined
- I $O(^AGFAC(FAC,11,FLIEN,1,"B","RACE",""))]"" Q
- ;
- ;Now add the RACE field
- W !
- K DA,DIE,DR
- N DA,DIC,X,Y
- S DA(2)=FAC,DA(1)=FLIEN
- S DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- S DIC(0)="LS"
- S X=".06"
- D ^DIC
- S PRFIEN=+Y
- I +PRFIEN W " REQUIRED? parameter added for site: ",$$GET1^DIQ(9999999.06,FAC_",",.01,"E")
- ;
- ;Set the required value to NO
- K DA,DIC,X,Y
- N DA,DIE,DR
- S DA(2)=FAC,DA(1)=FLIEN,DA=PRFIEN
- S DIE="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- S DR=".02////0"
- D ^DIE
- ;
- Q
- ;
- PREF(FAC) ;Add PREFERRED LANGUAGE to facility required field list
- ;
- N PRFIEN,DA,DIC,FLIEN,X,Y
- ;
- ;First Look for existing 9000001 entry
- S DA(1)=FAC
- S DIC="^AGFAC("_FAC_",11,"
- S DIC(0)="L"
- S X="9000001"
- D ^DIC
- Q:Y'>0
- S FLIEN=+Y
- ;
- ;Quit if PREFERRED LANGUAGE already defined
- I $O(^AGFAC(FAC,11,FLIEN,1,"B","PREFERRED LANGUAGE",""))]"" Q
- ;
- ;Now change the file to 9000001.86 so it can pass input transform check
- K DA,DIC,X,Y
- N DA,DIE,DR
- S DA(1)=FAC,DA=FLIEN
- S DIE="^AGFAC("_DA(1)_",11,"
- S DR=".01////9000001.86"
- D ^DIE
- ;
- ;Now add the PREFERRED LANGUAGE field
- W !
- K DA,DIE,DR
- N DA,DIC,X,Y
- S DA(2)=FAC,DA(1)=FLIEN
- S DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- S DIC(0)="LS"
- S X=".04"
- D ^DIC
- S PRFIEN=+Y
- I +PRFIEN W " REQUIRED? parameter added for site: ",$$GET1^DIQ(9999999.06,FAC_",",.01,"E")
- ;
- ;Set the required value to NO
- K DA,DIC,X,Y
- N DA,DIE,DR
- S DA(2)=FAC,DA(1)=FLIEN,DA=PRFIEN
- S DIE="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- S DR=".02////0"
- D ^DIE
- ;
- ;Now change the file back to 9000001
- K DA,DIE,DR
- N DA,DIE,DR
- S DA(1)=FAC,DA=FLIEN
- S DIE="^AGFAC("_DA(1)_",11,"
- S DR=".01////9000001"
- D ^DIE
- ;
- Q
- ;
- PRIM(FAC) ;Add PRIMARY LANGUAGE to facility required field list
- ;
- N PRFIEN,DA,DIC,FLIEN,X,Y
- ;
- ;First Look for existing 9000001 entry
- S DA(1)=FAC
- S DIC="^AGFAC("_FAC_",11,"
- S DIC(0)="L"
- S X="9000001"
- D ^DIC
- Q:Y'>0
- S FLIEN=+Y
- ;
- ;Quit if PRIMARY LANGUAGE already defined
- I $O(^AGFAC(FAC,11,FLIEN,1,"B","PRIMARY LANGUAGE",""))]"" Q
- ;
- ;Now change the file to 9000001.86 so it can pass input transform check
- K DA,DIC,X,Y
- N DA,DIE,DR
- S DA(1)=FAC,DA=FLIEN
- S DIE="^AGFAC("_DA(1)_",11,"
- S DR=".01////9000001.86"
- D ^DIE
- ;
- ;Now add the PRIMARY LANGUAGE field
- W !
- K DA,DIE,DR
- N DA,DIC,X,Y
- S DA(2)=FAC,DA(1)=FLIEN
- S DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- S DIC(0)="LS"
- S X=".02"
- D ^DIC
- S PRFIEN=+Y
- I +PRFIEN W " REQUIRED? parameter added for site: ",$$GET1^DIQ(9999999.06,FAC_",",.01,"E")
- ;
- ;Set the required value to NO
- K DA,DIC,X,Y
- N DA,DIE,DR
- S DA(2)=FAC,DA(1)=FLIEN,DA=PRFIEN
- S DIE="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- S DR=".02////0"
- D ^DIE
- ;
- ;Now change the file back to 9000001
- K DA,DIE,DR
- N DA,DIE,DR
- S DA(1)=FAC,DA=FLIEN
- S DIE="^AGFAC("_DA(1)_",11,"
- S DR=".01////9000001"
- D ^DIE
- ;
- Q
- AG71A9 ;VNGT/HS/BEE - Patient Registration 7.1 PATCH 9 POST INSTALL ; MAY 07, 2010
- +1 ;;7.1;PATIENT REGISTRATION;**9**;AUG 25, 2005
- +2 ;
- +3 QUIT
- +4 ;
- POST ;EP - From KIDS.
- +1 ;
- +2 NEW CLBEN,MMSG,IEN,AMIND
- +3 DO TS
- DO BMES^XPDUTL("Beginning post-install routine (POST^AG71A9).")
- +4 ;
- +5 SET MMSG=" --- AG v 7.1 Patch 9 has been installed into this uci --- "
- +6 ;
- +7 ;Set new 'LINK AOB TO ROI FIELD' to default of 'NO'
- +8 ;and define new facility parameter ROI/AOB required prompts
- +9 WRITE !
- +10 SET IEN=0
- FOR
- SET IEN=$ORDER(^AGFAC(IEN))
- IF 'IEN
- QUIT
- Begin DoDot:1
- +11 ;
- +12 ;Set up new ETHNICITY INFORMATION Required registration parameter prompt
- +13 DO ETHN^AG71A9(IEN)
- +14 ;
- +15 ;Set up new RACE Required registration parameter prompt
- +16 DO RACE^AG71A9(IEN)
- +17 ;
- +18 ;Set up new PREFERRED LANGUAGE Required registration parameter prompt
- +19 DO PREF^AG71A9(IEN)
- +20 ;
- +21 ;Set up new PRIMARY LANGUAGE Required registration parameter prompt
- +22 DO PRIM^AG71A9(IEN)
- +23 ;
- +24 ;Set up Homeless and Migrant prompts with default of no
- +25 DO HOM^AG71A9(IEN)
- End DoDot:1
- +26 ;
- +27 ;Remove the lock from the AGSETSITE option
- +28 NEW DIC,X,Y
- SET DIC="^DIC(19,"
- SET X="AGSETSITE"
- +29 DO ^DIC
- +30 IF +Y>0
- Begin DoDot:1
- +31 NEW DA,DIC,DIE,DR,X
- +32 SET DA=+Y
- +33 SET DIE="^DIC(19,"
- +34 SET DR="3////@"
- +35 DO ^DIE
- End DoDot:1
- +36 KILL DIC,X,Y
- +37 ;
- +38 ;Populate Race field based on CLASSIFICATION/BENEFICIARY
- +39 DO TS
- DO BMES^XPDUTL("AutoPopulating PATIENT RACE field (POST^AG71A9).")
- +40 ;Get Classification IEN
- SET CLBEN=$ORDER(^AUTTBEN("B","INDIAN/ALASKA NATIVE",""))
- +41 ;Get Amer/Ind IEN
- SET AMIND=$ORDER(^DIC(10,"B","AMERICAN INDIAN OR ALASKA NATIVE",""))
- +42 ;
- +43 IF CLBEN]""
- IF AMIND]""
- Begin DoDot:1
- +44 NEW DFN,X,ERROR
- +45 SET DFN=0
- FOR
- SET DFN=$ORDER(^DPT(DFN))
- IF 'DFN
- QUIT
- Begin DoDot:2
- +46 ;
- +47 ;Quit if CLASSIFICATION/BENEFICIARY not equal to INDIAN/ALASKA NATIVE
- +48 IF $$GET1^DIQ(9000001,DFN_",",1111,"I")'=CLBEN
- QUIT
- +49 ;
- +50 ;Update RACE
- +51 KILL DA,DIC,X,Y
- +52 NEW DA,DIE,DR
- +53 SET DA=DFN
- +54 SET DIE="^DPT("
- +55 SET DR=".06////"_AMIND
- +56 DO ^DIE
- End DoDot:2
- End DoDot:1
- +57 ;
- +58 DO TS
- DO BMES^XPDUTL("Delivering v 7.1 Patch 9 install message to select users...")
- +59 ;
- +60 ;Deliver Mail Message
- +61 DO MAIL(MMSG)
- +62 ;
- +63 DO TS
- DO BMES^XPDUTL("AG v 7.1 Patch 9 Post-install is complete.")
- +64 QUIT
- +65 ;
- MAIL(MMSG) ;Send install mail message.
- +1 NEW %,CNT,DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
- +2 KILL ^TMP("AG71MS",$JOB)
- +3 SET ^TMP("AG71MS",$JOB,1)=$GET(MMSG)
- +4 SET ^TMP("AG71MS",$JOB,2)=" "
- +5 SET CNT=3
- +6 ;
- +7 SET %=0
- +8 IF $GET(XPDA)=""
- QUIT
- +9 IF $GET(XPDBLD)=""
- QUIT
- +10 FOR
- SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
- IF '%
- QUIT
- SET ^TMP("AG71MS",$JOB,(%+CNT))=" "_^(%,0)
- +11 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)=""
- +12 FOR %="AGZMENU","XUMGR","XUPROG","XUPROGMODE"
- DO SINGLE(%)
- +13 DO ^XMD
- +14 KILL ^TMP("AG71MS",$JOB)
- +15 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 ;
- TS DO MES^XPDUTL($$HTE^XLFDT($HOROLOG))
- QUIT
- +1 ;
- HOM(FAC) ;Set Homeless and Migrant Display parameters
- +1 ;
- +2 NEW VAL
- +3 ;
- +4 ;Homeless Display
- +5 SET VAL=$$GET1^DIQ(9009061,FAC_",",28)
- IF VAL=""
- Begin DoDot:1
- +6 ;
- +7 ;Set the display to "YES"
- +8 KILL DA,DIC,X,Y
- +9 NEW DA,DIE,DR
- +10 SET DA=FAC
- +11 SET DIE="^AGFAC("
- +12 SET DR="28////Y"
- +13 DO ^DIE
- End DoDot:1
- +14 ;
- +15 ;Migrant Display
- +16 SET VAL=$$GET1^DIQ(9009061,FAC_",",27)
- IF VAL=""
- Begin DoDot:1
- +17 ;
- +18 ;Set the display to "YES"
- +19 KILL DA,DIC,X,Y
- +20 NEW DA,DIE,DR
- +21 SET DA=FAC
- +22 SET DIE="^AGFAC("
- +23 SET DR="27////Y"
- +24 DO ^DIE
- End DoDot:1
- +25 ;
- +26 QUIT
- +27 ;
- ETHN(FAC) ;Now add the ETHNICITY field
- +1 ;
- +2 NEW PRFIEN,DA,DIC,FLIEN,X,Y
- +3 ;
- +4 ;First Look for existing 2 entry
- +5 SET DA(1)=FAC
- +6 SET DIC="^AGFAC("_FAC_",11,"
- +7 SET DIC(0)="L"
- +8 SET X="2"
- +9 DO ^DIC
- +10 IF Y'>0
- QUIT
- +11 SET FLIEN=+Y
- +12 ;
- +13 ;Quit if ETHNICITY INFORMATION already defined
- +14 IF $ORDER(^AGFAC(FAC,11,FLIEN,1,"B","ETHNICITY INFORMATION",""))]""
- QUIT
- +15 ;
- +16 ;Now add the ETHNICITY field
- +17 WRITE !
- +18 KILL DA,DIE,DR
- +19 NEW DA,DIC,X,Y
- +20 SET DA(2)=FAC
- SET DA(1)=FLIEN
- +21 SET DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- +22 SET DIC(0)="LS"
- +23 SET X="6"
- +24 DO ^DIC
- +25 SET PRFIEN=+Y
- +26 IF +PRFIEN
- WRITE " REQUIRED? parameter added for site: ",$$GET1^DIQ(9999999.06,FAC_",",.01,"E")
- +27 ;
- +28 ;Set the required value to NO
- +29 KILL DA,DIC,X,Y
- +30 NEW DA,DIE,DR
- +31 SET DA(2)=FAC
- SET DA(1)=FLIEN
- SET DA=PRFIEN
- +32 SET DIE="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- +33 SET DR=".02////0"
- +34 DO ^DIE
- +35 QUIT
- +36 ;
- RACE(FAC) ;Now add the RACE field
- +1 ;
- +2 NEW PRFIEN,DA,DIC,FLIEN,X,Y
- +3 ;
- +4 ;First Look for existing 2 entry
- +5 SET DA(1)=FAC
- +6 SET DIC="^AGFAC("_FAC_",11,"
- +7 SET DIC(0)="L"
- +8 SET X="2"
- +9 DO ^DIC
- +10 IF Y'>0
- QUIT
- +11 SET FLIEN=+Y
- +12 ;
- +13 ;Quit if RACE already defined
- +14 IF $ORDER(^AGFAC(FAC,11,FLIEN,1,"B","RACE",""))]""
- QUIT
- +15 ;
- +16 ;Now add the RACE field
- +17 WRITE !
- +18 KILL DA,DIE,DR
- +19 NEW DA,DIC,X,Y
- +20 SET DA(2)=FAC
- SET DA(1)=FLIEN
- +21 SET DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- +22 SET DIC(0)="LS"
- +23 SET X=".06"
- +24 DO ^DIC
- +25 SET PRFIEN=+Y
- +26 IF +PRFIEN
- WRITE " REQUIRED? parameter added for site: ",$$GET1^DIQ(9999999.06,FAC_",",.01,"E")
- +27 ;
- +28 ;Set the required value to NO
- +29 KILL DA,DIC,X,Y
- +30 NEW DA,DIE,DR
- +31 SET DA(2)=FAC
- SET DA(1)=FLIEN
- SET DA=PRFIEN
- +32 SET DIE="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- +33 SET DR=".02////0"
- +34 DO ^DIE
- +35 ;
- +36 QUIT
- +37 ;
- PREF(FAC) ;Add PREFERRED LANGUAGE to facility required field list
- +1 ;
- +2 NEW PRFIEN,DA,DIC,FLIEN,X,Y
- +3 ;
- +4 ;First Look for existing 9000001 entry
- +5 SET DA(1)=FAC
- +6 SET DIC="^AGFAC("_FAC_",11,"
- +7 SET DIC(0)="L"
- +8 SET X="9000001"
- +9 DO ^DIC
- +10 IF Y'>0
- QUIT
- +11 SET FLIEN=+Y
- +12 ;
- +13 ;Quit if PREFERRED LANGUAGE already defined
- +14 IF $ORDER(^AGFAC(FAC,11,FLIEN,1,"B","PREFERRED LANGUAGE",""))]""
- QUIT
- +15 ;
- +16 ;Now change the file to 9000001.86 so it can pass input transform check
- +17 KILL DA,DIC,X,Y
- +18 NEW DA,DIE,DR
- +19 SET DA(1)=FAC
- SET DA=FLIEN
- +20 SET DIE="^AGFAC("_DA(1)_",11,"
- +21 SET DR=".01////9000001.86"
- +22 DO ^DIE
- +23 ;
- +24 ;Now add the PREFERRED LANGUAGE field
- +25 WRITE !
- +26 KILL DA,DIE,DR
- +27 NEW DA,DIC,X,Y
- +28 SET DA(2)=FAC
- SET DA(1)=FLIEN
- +29 SET DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- +30 SET DIC(0)="LS"
- +31 SET X=".04"
- +32 DO ^DIC
- +33 SET PRFIEN=+Y
- +34 IF +PRFIEN
- WRITE " REQUIRED? parameter added for site: ",$$GET1^DIQ(9999999.06,FAC_",",.01,"E")
- +35 ;
- +36 ;Set the required value to NO
- +37 KILL DA,DIC,X,Y
- +38 NEW DA,DIE,DR
- +39 SET DA(2)=FAC
- SET DA(1)=FLIEN
- SET DA=PRFIEN
- +40 SET DIE="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- +41 SET DR=".02////0"
- +42 DO ^DIE
- +43 ;
- +44 ;Now change the file back to 9000001
- +45 KILL DA,DIE,DR
- +46 NEW DA,DIE,DR
- +47 SET DA(1)=FAC
- SET DA=FLIEN
- +48 SET DIE="^AGFAC("_DA(1)_",11,"
- +49 SET DR=".01////9000001"
- +50 DO ^DIE
- +51 ;
- +52 QUIT
- +53 ;
- PRIM(FAC) ;Add PRIMARY LANGUAGE to facility required field list
- +1 ;
- +2 NEW PRFIEN,DA,DIC,FLIEN,X,Y
- +3 ;
- +4 ;First Look for existing 9000001 entry
- +5 SET DA(1)=FAC
- +6 SET DIC="^AGFAC("_FAC_",11,"
- +7 SET DIC(0)="L"
- +8 SET X="9000001"
- +9 DO ^DIC
- +10 IF Y'>0
- QUIT
- +11 SET FLIEN=+Y
- +12 ;
- +13 ;Quit if PRIMARY LANGUAGE already defined
- +14 IF $ORDER(^AGFAC(FAC,11,FLIEN,1,"B","PRIMARY LANGUAGE",""))]""
- QUIT
- +15 ;
- +16 ;Now change the file to 9000001.86 so it can pass input transform check
- +17 KILL DA,DIC,X,Y
- +18 NEW DA,DIE,DR
- +19 SET DA(1)=FAC
- SET DA=FLIEN
- +20 SET DIE="^AGFAC("_DA(1)_",11,"
- +21 SET DR=".01////9000001.86"
- +22 DO ^DIE
- +23 ;
- +24 ;Now add the PRIMARY LANGUAGE field
- +25 WRITE !
- +26 KILL DA,DIE,DR
- +27 NEW DA,DIC,X,Y
- +28 SET DA(2)=FAC
- SET DA(1)=FLIEN
- +29 SET DIC="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- +30 SET DIC(0)="LS"
- +31 SET X=".02"
- +32 DO ^DIC
- +33 SET PRFIEN=+Y
- +34 IF +PRFIEN
- WRITE " REQUIRED? parameter added for site: ",$$GET1^DIQ(9999999.06,FAC_",",.01,"E")
- +35 ;
- +36 ;Set the required value to NO
- +37 KILL DA,DIC,X,Y
- +38 NEW DA,DIE,DR
- +39 SET DA(2)=FAC
- SET DA(1)=FLIEN
- SET DA=PRFIEN
- +40 SET DIE="^AGFAC("_DA(2)_",11,"_DA(1)_",1,"
- +41 SET DR=".02////0"
- +42 DO ^DIE
- +43 ;
- +44 ;Now change the file back to 9000001
- +45 KILL DA,DIE,DR
- +46 NEW DA,DIE,DR
- +47 SET DA(1)=FAC
- SET DA=FLIEN
- +48 SET DIE="^AGFAC("_DA(1)_",11,"
- +49 SET DR=".01////9000001"
- +50 DO ^DIE
- +51 ;
- +52 QUIT