222 lines
8.8 KiB
Mathematica
222 lines
8.8 KiB
Mathematica
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
|
|
;
|