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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMP4I1 9249 printed Sep 23, 2025@19:23:49 Page 2
PXRMP4I1 ; SLC/PKR - PXRM*2.0*4 init routine. ;06/28/2006
+1 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+2 ;
+3 ;==========================================
CLEAN(FILENUM,NAME) ;Clean entry NAME in file number FILENUM.
+1 NEW DFDA,ENTRY,FDAIEN,FIELD,GBL,IEN,IENS,IND,LOCK,MSG,REQLIST,SFDA
+2 SET IEN=$$FIND1^DIC(FILENUM,"","BX",NAME)
+3 IF IEN=0
QUIT
+4 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+5 IF GBL=""
QUIT
+6 SET ENTRY=GBL_IEN_")"
+7 SET IENS=IEN_","
+8 SET DFDA(FILENUM,IENS,.01)="@"
+9 DO FILE^DID(FILENUM,"N","REQUIRED IDENTIFIERS","REQLIST","MSG")
+10 SET IND=0
+11 FOR
SET IND=$ORDER(REQLIST("REQUIRED IDENTIFIERS",IND))
if IND=""
QUIT
Begin DoDot:1
+12 SET FIELD=REQLIST("REQUIRED IDENTIFIERS",IND,"FIELD")
+13 SET SFDA(FILENUM,"+1,",FIELD)=$$GET1^DIQ(FILENUM,IENS,FIELD,"","","MSG")
End DoDot:1
+14 SET FDAIEN(1)=IEN
+15 SET LOCK=0
+16 FOR IND=1:1:3
if LOCK
QUIT
Begin DoDot:1
+17 LOCK +@ENTRY:2
+18 SET LOCK=$TEST
End DoDot:1
+19 IF LOCK=0
Begin DoDot:1
+20 NEW TEXT
+21 SET TEXT="No lock for file "_FILENUM_" entry "_IEN
+22 DO BMES^XPDUTL(.TEXT)
End DoDot:1
QUIT
+23 DO FILE^DIE("","DFDA","MSG")
+24 IF $DATA(MSG)
DO AWRITE^PXRMUTIL("MSG")
HANG 2
+25 KILL MSG
+26 DO UPDATE^DIE("E","SFDA","FDAIEN","MSG")
+27 LOCK -@ENTRY
+28 IF $DATA(MSG)
DO AWRITE^PXRMUTIL("MSG")
HANG 2
+29 QUIT
+30 ;
+31 ;==========================================
GECDIA ;
+1 ;
+2 DO BMES^XPDUTL("Re-Setting Heath FactorS Syn. Entries.")
+3 NEW HFIEN,SYN1,SYN0
+4 SET FHIEN=0
+5 SET SYN1="GEC3F CARE RECOMMENDATIONS 1"
+6 SET SYN0="GEC3F CARE RECOMMENDATIONS 0"
+7 ;
+8 ;**VA-DG GEC PROGNOSIS
+9 SET FHIEN=$ORDER(^AUTTHF("B","GEC EXACERBATION CHR ILLNESS LAST 7D-YES",0))
+10 SET $PIECE(^AUTTHF(FHIEN,0),"^",9)=SYN1
+11 ;
+12 SET FHIEN=$ORDER(^AUTTHF("B","GEC EXACERBATION CHR ILLNESS LAST 7D-NO",0))
DO SYN0
+13 ;
+14 SET FHIEN=$ORDER(^AUTTHF("B","GEC CAPABLE INCREASED INDEPENDENCE-YES",0))
+15 SET $PIECE(^AUTTHF(FHIEN,0),"^",9)=SYN1
+16 ;
+17 SET FHIEN=$ORDER(^AUTTHF("B","GEC CAPABLE INCREASED INDEPENDENCE-NO",0))
DO SYN0
+18 ;
+19 SET FHIEN=$ORDER(^AUTTHF("B","GEC LIFE EXPECTANCY < 6MO-YES",0))
+20 SET $PIECE(^AUTTHF(FHIEN,0),"^",9)=SYN1
+21 ;
+22 SET FHIEN=$ORDER(^AUTTHF("B","GEC LIFE EXPECTANCY < 6MO-NO",0))
DO SYN0
+23 ;
+24 ;**VA-DG GEC WEIGHT BEARING
+25 SET FHIEN=$ORDER(^AUTTHF("B","GEC FULL WEIGHT BEARING",0))
DO SYN0
+26 ;
+27 SET FHIEN=$ORDER(^AUTTHF("B","GEC PARTIAL WEIGHT BEARING",0))
DO SYN0
+28 ;
+29 SET FHIEN=$ORDER(^AUTTHF("B","GEC NON WEIGHTBEARING",0))
DO SYN0
+30 ;
+31 ;**VA-DG GEC DIET
+32 ;
+33 SET FHIEN=$ORDER(^AUTTHF("B","GEC REGULAR DIET",0))
DO SYN0
+34 ;
+35 SET FHIEN=$ORDER(^AUTTHF("B","GEC MODIFIED DIET",0))
DO SYN0
+36 ;
+37 ;**VA-DG GEC PROSTHETIC REQUESTS
+38 ;
+39 SET FHIEN=$ORDER(^AUTTHF("B","GEC HOSPITAL BED",0))
DO SYN0
+40 ;
+41 SET FHIEN=$ORDER(^AUTTHF("B","GEC SPECIAL MATTRESS",0))
DO SYN0
+42 ;
+43 SET FHIEN=$ORDER(^AUTTHF("B","GEC TRAPEZE",0))
DO SYN0
+44 ;
+45 SET FHIEN=$ORDER(^AUTTHF("B","GEC WALKER/ASSISTIVE DEVICE",0))
DO SYN0
+46 ;
+47 SET FHIEN=$ORDER(^AUTTHF("B","GEC CANE",0))
DO SYN0
+48 ;
+49 SET FHIEN=$ORDER(^AUTTHF("B","GEC WHEELCHAIR",0))
DO SYN0
+50 ;
+51 SET FHIEN=$ORDER(^AUTTHF("B","GEC ADL EQUIPMENT",0))
DO SYN0
+52 ;
+53 SET FHIEN=$ORDER(^AUTTHF("B","GEC ORTHOTIC/SPLINT",0))
DO SYN0
+54 ;
+55 SET FHIEN=$ORDER(^AUTTHF("B","GEC OTHER EQUIPMENT",0))
DO SYN0
+56 QUIT
+57 ;
+58 ;==========================================
RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
+1 ;file number FILENUM.
+2 NEW DA,DIE,DR
+3 SET DA=$$FIND1^DIC(FILENUM,"","BX",OLDNAME)
+4 IF DA=0
QUIT
+5 SET DIE=FILENUM
+6 SET DR=".01///^S X=NEWNAME"
+7 DO ^DIE
+8 QUIT
+9 ;
+10 ;==========================================
RELTEMP ;Rename the Extract list templates.
+1 NEW IND,NEWNAME,NUM,OLDNAME
+2 DO BMES^XPDUTL("Renaming extract List Templates")
+3 SET NUM=0
+4 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING EDIT"
SET NEWNAME(NUM)="PXRM COUNT RULE EDIT"
+5 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GROUPS"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUPS"
+6 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GRP EDIT"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GRP EDIT"
+7 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDINGS"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING RULES"
+8 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETERS"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITIONS"
+9 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER EDIT"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION EDIT"
+10 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER DISPLAY"
SET NEWNAME(NUM)="PXRM EXTRACT DEF DISPLAY"
+11 FOR IND=1:1:NUM
Begin DoDot:1
+12 DO RENAME(409.61,OLDNAME(IND),NEWNAME(IND))
+13 DO CLEAN(409.61,NEWNAME(IND))
End DoDot:1
+14 DO CLEAN(409.61,"PXRM EXTRACT HELP")
+15 DO CLEAN(409.61,"PXRM EXTRACT HISTORY")
+16 DO CLEAN(409.61,"PXRM EXTRACT MANAGEMENT")
+17 DO CLEAN(409.61,"PXRM EXTRACT SUMMARY")
+18 DO CLEAN(409.61,"PXRM EXTRACT TRANSMISSIONS")
+19 DO CLEAN(409.61,"PXRM LIST RULE MANAGEMENT")
+20 QUIT
+21 ;
+22 ;==========================================
REOPTS ;Rename the Extract options.
+1 NEW IND,NEWNAME,NUM,OLDNAME
+2 DO BMES^XPDUTL("Renaming extract options")
+3 SET NUM=0
+4 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDINGS"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING RULES"
+5 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT GROUPS"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUPS"
+6 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETERS"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION"
+7 FOR IND=1:1:NUM
Begin DoDot:1
+8 DO RENAME(19,OLDNAME(IND),NEWNAME(IND))
+9 DO CLEAN(19,NEWNAME(IND))
End DoDot:1
+10 DO CLEAN(19,"PXRM EXTRACT MENU")
+11 DO CLEAN(19,"PXRM EXTRACT MANAGEMENT")
+12 DO CLEAN(19,"PXRM EXTRACT PATIENT LIST")
+13 DO CLEAN(19,"PXRM LIST RULE MANAGEMENT")
+14 QUIT
+15 ;
+16 ;==========================================
REPROTS ;Rename the Extract protocols.
+1 NEW IND,NEWNAME,NUM,OLDNAME
+2 DO BMES^XPDUTL("Renaming extract protocols")
+3 SET NUM=0
+4 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING CREATE"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE CREATE"
+5 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING DISPLAY MENU"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE DISPLAY MENU"
+6 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING DISPLAY/EDIT"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE DISPLAY/EDIT"
+7 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING EDIT"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE EDIT"
+8 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING EXIT"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE EXIT"
+9 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP CREATE"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP CREATE"
+10 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP DISPLAY MENU"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP DISPLAY MENU"
+11 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP DISPLAY/EDIT"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP DISPLAY/EDIT"
+12 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP EDIT"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP EDIT"
+13 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP EXIT"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP EXIT"
+14 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP MENU"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP MENU"
+15 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP SELECT ENTRY"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP SELECT ENTRY"
+16 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING GROUPS"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUPS"
+17 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING MENU"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE MENU"
+18 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT FINDING SELECT ENTRY"
SET NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE SELECT ENTRY"
+19 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER CREATE"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION CREATE"
+20 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER DISPLAY MENU"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION DISPLAY MENU"
+21 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER DISPLAY/EDIT"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION DISPLAY/EDIT"
+22 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER EDIT"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION EDIT"
+23 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER EXIT"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION EXIT"
+24 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER MANAGEMENT"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION MANAGEMENT"
+25 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER MENU"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION MENU"
+26 SET NUM=NUM+1
SET OLDNAME(NUM)="PXRM EXTRACT PARAMETER SELECT ENTRY"
SET NEWNAME(NUM)="PXRM EXTRACT DEFINITION SELECT ENTRY"
+27 FOR IND=1:1:NUM
Begin DoDot:1
+28 DO RENAME(101,OLDNAME(IND),NEWNAME(IND))
+29 DO CLEAN(101,NEWNAME(IND))
End DoDot:1
+30 QUIT
+31 ;
+32 ;==========================================
SYN0 ;
+1 SET $PIECE(^AUTTHF(FHIEN,0),"^",9)=SYN0
+2 QUIT
+3 ;
+4 ;==========================================
SLABENOD ;Make sure the enodes are set correctly for lab findings.
+1 NEW DA,FI,IEN,X
+2 DO BMES^XPDUTL("Setting ENODEs for lab findings.")
+3 SET IEN=0
+4 FOR
SET IEN=+$ORDER(^PXD(811.9,IEN))
if IEN=0
QUIT
Begin DoDot:1
+5 IF '$DATA(^PXD(811.9,IEN,20,"E","LAB(60,"))
QUIT
+6 KILL ^PXD(811.9,IEN,20,"E","LAB(60,")
+7 SET FI=0
+8 FOR
SET FI=+$ORDER(^PXD(811.9,IEN,20,FI))
if FI=0
QUIT
Begin DoDot:2
+9 SET X=$PIECE(^PXD(811.9,IEN,20,FI,0),U,1)
+10 IF $PIECE(X,";",2)'["LAB(60,"
QUIT
+11 SET DA=FI
SET DA(1)=IEN
+12 DO SENODE^PXRMENOD(.X,.DA,811.9)
End DoDot:2
End DoDot:1
+13 ;
+14 SET IEN=0
+15 FOR
SET IEN=+$ORDER(^PXRMD(811.5,IEN))
if IEN=0
QUIT
Begin DoDot:1
+16 IF '$DATA(^PXRMD(811.5,IEN,20,"E","LAB(60,"))
QUIT
+17 KILL ^PXRMD(811.5,IEN,20,"E","LAB(60,")
+18 SET FI=0
+19 FOR
SET FI=+$ORDER(^PXRMD(811.5,IEN,20,FI))
if FI=0
QUIT
Begin DoDot:2
+20 SET X=$PIECE(^PXRMD(811.5,IEN,20,FI,0),U,1)
+21 IF $PIECE(X,";",2)'["LAB(60,"
QUIT
+22 SET DA=FI
SET DA(1)=IEN
+23 DO SENODE^PXRMENOD(.X,.DA,811.5)
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
+26 ;==========================================
SNEXTIP ;Set the INCLUDE DECEASED PATIENTS and INCLUDE TEST PATIENTS
+1 ;parameters in the the national extracts.
+2 NEW IEN,NAME,SEQ
+3 FOR NAME="VA-IHD QUERI","VA-MH QUERI"
Begin DoDot:1
+4 SET IEN=$ORDER(^PXRM(810.2,"B",NAME,""))
+5 SET SEQ=0
+6 FOR
SET SEQ=+$ORDER(^PXRM(810.2,IEN,10,SEQ))
if SEQ=0
QUIT
Begin DoDot:2
+7 SET $PIECE(^PXRM(810.2,IEN,10,SEQ,0),U,4,5)=1_U_0
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
