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

PXRMP4I1.m

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