PXRMP4I1 ; SLC/PKR - PXRM*2.0*4 init routine. ;06/28/2006
 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
 ;
 ;==========================================
CLEAN(FILENUM,NAME) ;Clean entry NAME in file number FILENUM.
 N DFDA,ENTRY,FDAIEN,FIELD,GBL,IEN,IENS,IND,LOCK,MSG,REQLIST,SFDA
 S IEN=$$FIND1^DIC(FILENUM,"","BX",NAME)
 I IEN=0 Q
 S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
 I GBL="" Q
 S ENTRY=GBL_IEN_")"
 S IENS=IEN_","
 S DFDA(FILENUM,IENS,.01)="@"
 D FILE^DID(FILENUM,"N","REQUIRED IDENTIFIERS","REQLIST","MSG")
 S IND=0
 F  S IND=$O(REQLIST("REQUIRED IDENTIFIERS",IND)) Q:IND=""  D
 . S FIELD=REQLIST("REQUIRED IDENTIFIERS",IND,"FIELD")
 . S SFDA(FILENUM,"+1,",FIELD)=$$GET1^DIQ(FILENUM,IENS,FIELD,"","","MSG")
 S FDAIEN(1)=IEN
 S LOCK=0
 F IND=1:1:3 Q:LOCK  D
 . L +@ENTRY:2
 . S LOCK=$T
 I LOCK=0 D  Q
 . N TEXT
 . S TEXT="No lock for file "_FILENUM_" entry "_IEN
 . D BMES^XPDUTL(.TEXT)
 D FILE^DIE("","DFDA","MSG")
 I $D(MSG) D AWRITE^PXRMUTIL("MSG") H 2
 K MSG
 D UPDATE^DIE("E","SFDA","FDAIEN","MSG")
 L -@ENTRY
 I $D(MSG) D AWRITE^PXRMUTIL("MSG") H 2
 Q
 ;
 ;==========================================
GECDIA ;
 ;
 D BMES^XPDUTL("Re-Setting Heath FactorS Syn. Entries.")
 N HFIEN,SYN1,SYN0
 S FHIEN=0
 S SYN1="GEC3F CARE RECOMMENDATIONS 1"
 S SYN0="GEC3F CARE RECOMMENDATIONS 0"
 ;
 ;**VA-DG GEC PROGNOSIS
 S FHIEN=$O(^AUTTHF("B","GEC EXACERBATION CHR ILLNESS LAST 7D-YES",0))
 S $P(^AUTTHF(FHIEN,0),"^",9)=SYN1
 ;
 S FHIEN=$O(^AUTTHF("B","GEC EXACERBATION CHR ILLNESS LAST 7D-NO",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC CAPABLE INCREASED INDEPENDENCE-YES",0))
 S $P(^AUTTHF(FHIEN,0),"^",9)=SYN1
 ;
 S FHIEN=$O(^AUTTHF("B","GEC CAPABLE INCREASED INDEPENDENCE-NO",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC LIFE EXPECTANCY < 6MO-YES",0))
 S $P(^AUTTHF(FHIEN,0),"^",9)=SYN1
 ;
 S FHIEN=$O(^AUTTHF("B","GEC LIFE EXPECTANCY < 6MO-NO",0)) D SYN0
 ;
 ;**VA-DG GEC WEIGHT BEARING
 S FHIEN=$O(^AUTTHF("B","GEC FULL WEIGHT BEARING",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC PARTIAL WEIGHT BEARING",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC NON WEIGHTBEARING",0)) D SYN0
 ;
 ;**VA-DG GEC DIET
 ;
 S FHIEN=$O(^AUTTHF("B","GEC REGULAR DIET",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC MODIFIED DIET",0)) D SYN0
 ;
 ;**VA-DG GEC PROSTHETIC REQUESTS
 ;
 S FHIEN=$O(^AUTTHF("B","GEC HOSPITAL BED",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC SPECIAL MATTRESS",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC TRAPEZE",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC WALKER/ASSISTIVE DEVICE",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC CANE",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC WHEELCHAIR",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC ADL EQUIPMENT",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC ORTHOTIC/SPLINT",0)) D SYN0
 ;
 S FHIEN=$O(^AUTTHF("B","GEC OTHER EQUIPMENT",0)) D SYN0
 Q
 ;
 ;==========================================
RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
 ;file number FILENUM.
 N DA,DIE,DR
 S DA=$$FIND1^DIC(FILENUM,"","BX",OLDNAME)
 I DA=0 Q
 S DIE=FILENUM
 S DR=".01///^S X=NEWNAME"
 D ^DIE
 Q
 ;
 ;==========================================
RELTEMP ;Rename the Extract list templates.
 N IND,NEWNAME,NUM,OLDNAME
 D BMES^XPDUTL("Renaming extract List Templates")
 S NUM=0
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING EDIT",NEWNAME(NUM)="PXRM COUNT RULE EDIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUPS",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUPS"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GRP EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING GRP EDIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDINGS",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULES"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETERS",NEWNAME(NUM)="PXRM EXTRACT DEFINITIONS"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER EDIT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION EDIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER DISPLAY",NEWNAME(NUM)="PXRM EXTRACT DEF DISPLAY"
 F IND=1:1:NUM D
 . D RENAME(409.61,OLDNAME(IND),NEWNAME(IND))
 . D CLEAN(409.61,NEWNAME(IND))
 D CLEAN(409.61,"PXRM EXTRACT HELP")
 D CLEAN(409.61,"PXRM EXTRACT HISTORY")
 D CLEAN(409.61,"PXRM EXTRACT MANAGEMENT")
 D CLEAN(409.61,"PXRM EXTRACT SUMMARY")
 D CLEAN(409.61,"PXRM EXTRACT TRANSMISSIONS")
 D CLEAN(409.61,"PXRM LIST RULE MANAGEMENT")
 Q
 ;
 ;==========================================
REOPTS ;Rename the Extract options.
 N IND,NEWNAME,NUM,OLDNAME
 D BMES^XPDUTL("Renaming extract options")
 S NUM=0
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDINGS",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULES"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT GROUPS",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUPS"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETERS",NEWNAME(NUM)="PXRM EXTRACT DEFINITION"
 F IND=1:1:NUM D
 . D RENAME(19,OLDNAME(IND),NEWNAME(IND))
 . D CLEAN(19,NEWNAME(IND))
 D CLEAN(19,"PXRM EXTRACT MENU")
 D CLEAN(19,"PXRM EXTRACT MANAGEMENT")
 D CLEAN(19,"PXRM EXTRACT PATIENT LIST")
 D CLEAN(19,"PXRM LIST RULE MANAGEMENT")
 Q
 ;
 ;==========================================
REPROTS ;Rename the Extract protocols.
 N IND,NEWNAME,NUM,OLDNAME
 D BMES^XPDUTL("Renaming extract protocols")
 S NUM=0
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING CREATE",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE CREATE"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING DISPLAY MENU",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE DISPLAY MENU"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING DISPLAY/EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE DISPLAY/EDIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE EDIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING EXIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE EXIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP CREATE",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP CREATE"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP DISPLAY MENU",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP DISPLAY MENU"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP DISPLAY/EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP DISPLAY/EDIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP EDIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP EXIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP EXIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP MENU",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP MENU"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP SELECT ENTRY",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP SELECT ENTRY"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUPS",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUPS"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING MENU",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE MENU"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING SELECT ENTRY",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE SELECT ENTRY"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER CREATE",NEWNAME(NUM)="PXRM EXTRACT DEFINITION CREATE"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER DISPLAY MENU",NEWNAME(NUM)="PXRM EXTRACT DEFINITION DISPLAY MENU"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER DISPLAY/EDIT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION DISPLAY/EDIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER EDIT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION EDIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER EXIT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION EXIT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER MANAGEMENT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION MANAGEMENT"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER MENU",NEWNAME(NUM)="PXRM EXTRACT DEFINITION MENU"
 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER SELECT ENTRY",NEWNAME(NUM)="PXRM EXTRACT DEFINITION SELECT ENTRY"
 F IND=1:1:NUM D
 . D RENAME(101,OLDNAME(IND),NEWNAME(IND))
 . D CLEAN(101,NEWNAME(IND))
 Q
 ;
 ;==========================================
SYN0 ;
 S $P(^AUTTHF(FHIEN,0),"^",9)=SYN0
 Q
 ;
 ;==========================================
SLABENOD ;Make sure the enodes are set correctly for lab findings.
 N DA,FI,IEN,X
 D BMES^XPDUTL("Setting ENODEs for lab findings.")
 S IEN=0
 F  S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0  D
 . I '$D(^PXD(811.9,IEN,20,"E","LAB(60,")) Q
 . K ^PXD(811.9,IEN,20,"E","LAB(60,")
 . S FI=0
 . F  S FI=+$O(^PXD(811.9,IEN,20,FI)) Q:FI=0  D
 .. S X=$P(^PXD(811.9,IEN,20,FI,0),U,1)
 .. I $P(X,";",2)'["LAB(60," Q
 .. S DA=FI,DA(1)=IEN
 .. D SENODE^PXRMENOD(.X,.DA,811.9)
 ;
 S IEN=0
 F  S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0  D
 . I '$D(^PXRMD(811.5,IEN,20,"E","LAB(60,")) Q
 . K ^PXRMD(811.5,IEN,20,"E","LAB(60,")
 . S FI=0
 . F  S FI=+$O(^PXRMD(811.5,IEN,20,FI)) Q:FI=0  D
 .. S X=$P(^PXRMD(811.5,IEN,20,FI,0),U,1)
 .. I $P(X,";",2)'["LAB(60," Q
 .. S DA=FI,DA(1)=IEN
 .. D SENODE^PXRMENOD(.X,.DA,811.5)
 Q
 ;
 ;==========================================
SNEXTIP ;Set the INCLUDE DECEASED PATIENTS and INCLUDE TEST PATIENTS
 ;parameters in the the national extracts.
 N IEN,NAME,SEQ
 F NAME="VA-IHD QUERI","VA-MH QUERI" D
 . S IEN=$O(^PXRM(810.2,"B",NAME,""))
 . S SEQ=0
 . F  S SEQ=+$O(^PXRM(810.2,IEN,10,SEQ)) Q:SEQ=0  D
 .. S $P(^PXRM(810.2,IEN,10,SEQ,0),U,4,5)=1_U_0
 Q
 ;