PXRMEGED ; SLC/PJH - Extract Counting Group Editor ;01/28/2013
;;2.0;CLINICAL REMINDERS;**4,26**;Feb 04, 2005;Build 404
;
;Main entry point for PXRM EXTRACT COUNTING GRP EDIT
START(IEN) ;
N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
S X="IORESET"
D ENDR^%ZISS
S VALMCNT=0
D EN^VALM("PXRM EXTRACT COUNTING GRP EDIT")
Q
;
BLDLIST(IEN) ;Build workfile
N FLDS,GBL,PXRMROOT
S FLDS="[PXRM EXTRACT COUNTING GROUP]"
S GBL="^TMP(""PXRMEGED"",$J)"
S GBL=$NA(@GBL)
S PXRMROOT="^PXRM(810.8,"
K ^TMP("PXRMEGED",$J)
D DIP^PXRMUTIL(GBL,IEN,PXRMROOT,FLDS)
S VALMCNT=$O(^TMP("PXRMEGED",$J,""),-1)
Q
;
ENTRY ;Entry code
D BLDLIST(IEN)
Q
;
EXIT ;Exit code
K ^TMP("PXRMEGED",$J)
K ^TMP("PXRMEGEDH",$J)
D CLEAN^VALM10
D FULL^VALM1
S VALMBCK="Q"
Q
;
HDR ; Header code
S VALMHDR(1)=""
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
HLP ;Help code
N ORU,ORUPRMT,SUB,XQORM
S SUB="PXRMEGEDH"
D EN^VALM("PXRM EXTRACT HELP")
Q
;
INIT ;Init
S VALMCNT=0
Q
;
PEXIT ;PXRM EXCH MENU protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
;Reset after page up/down etc
Q
;
ADD ;Add Rule
N DA,DIC,DONE,DTOUT,DUOUT,DLAYGO,HED,Y
S HED="ADD EXTRACT COUNTING GROUP",DONE=0
W IORESET,!
F D Q:$D(DTOUT) Q:DONE
.S DIC="^PXRM(810.8,"
.;Set the starting place for additions.
.D SETSTART^PXRMCOPY(DIC)
.S DIC(0)="AELMQ",DLAYGO=810.8
.S DIC("A")="Select EXTRACT COUNTING GROUP to add: "
.D ^DIC
.I $D(DUOUT) S DTOUT=1
.I ($D(DTOUT))!($D(DUOUT)) Q
.I Y=-1 K DIC S DTOUT=1 Q
.I $P(Y,U,3)'=1 W !,"This extract counting group name already exists" Q
.S DA=$P(Y,U,1)
.;Edit Extract Counting Group
.D EDIT(DA)
.S:$D(DA) DONE=1,GROUP(DA)=""
Q
;
EDIT(DA) ;Edit Rule
I '$$VEDIT^PXRMUTIL("^PXRM(810.8,",DA) D Q
.W !!,?5,"VA- and national class rules may not be edited" H 2
.S VALMBCK="R"
;
Q:'$$LOCK(DA)
W IORESET
N CS1,CS2,DIC,DIDEL,DIE,DR,DTOUT,DUOUT,ODA,Y
;Save checksum
S CS1=$$FILE^PXRMEXCS(810.8,DA)
;
S DIE="^PXRM(810.8,",DIDEL=810.8,ODA=DA,DR="[PXRM EXTRACT COUNTING GROUP]"
;
;Edit extract counting group then unlock
D ^DIE,UNLOCK(ODA)
;Deleted ???
I '$D(DA) S VALMBCK="Q" Q
;
;Update edit history
D
.S CS2=$$FILE^PXRMEXCS(810.8,DA) Q:CS2=CS1 Q:+CS2=0
.D SEHIST^PXRMUTIL(810.8,DIC,DA)
;
S VALMBCK="R"
Q
;
EGEDIT ;Edit Rule
D EDIT(IEN) Q:VALMBCK="Q"
;
;Rebuild Workfile
D BLDLIST(IEN)
Q
;
LOCK(DA) ;Lock the record
L +^PXRM(810.7,DA):DILOCKTM I Q 1
E W !!,?5,"Another user is editing this file, try later" H 2 Q 0
;
SCREEN ;validate rule type
Q
;
UNLOCK(DA) ;Unlock the record
L -^PXRM(810.7,DA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEGED 2727 printed Dec 13, 2024@01:44:28 Page 2
PXRMEGED ; SLC/PJH - Extract Counting Group Editor ;01/28/2013
+1 ;;2.0;CLINICAL REMINDERS;**4,26**;Feb 04, 2005;Build 404
+2 ;
+3 ;Main entry point for PXRM EXTRACT COUNTING GRP EDIT
START(IEN) ;
+1 NEW PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+2 SET X="IORESET"
+3 DO ENDR^%ZISS
+4 SET VALMCNT=0
+5 DO EN^VALM("PXRM EXTRACT COUNTING GRP EDIT")
+6 QUIT
+7 ;
BLDLIST(IEN) ;Build workfile
+1 NEW FLDS,GBL,PXRMROOT
+2 SET FLDS="[PXRM EXTRACT COUNTING GROUP]"
+3 SET GBL="^TMP(""PXRMEGED"",$J)"
+4 SET GBL=$NAME(@GBL)
+5 SET PXRMROOT="^PXRM(810.8,"
+6 KILL ^TMP("PXRMEGED",$JOB)
+7 DO DIP^PXRMUTIL(GBL,IEN,PXRMROOT,FLDS)
+8 SET VALMCNT=$ORDER(^TMP("PXRMEGED",$JOB,""),-1)
+9 QUIT
+10 ;
ENTRY ;Entry code
+1 DO BLDLIST(IEN)
+2 QUIT
+3 ;
EXIT ;Exit code
+1 KILL ^TMP("PXRMEGED",$JOB)
+2 KILL ^TMP("PXRMEGEDH",$JOB)
+3 DO CLEAN^VALM10
+4 DO FULL^VALM1
+5 SET VALMBCK="Q"
+6 QUIT
+7 ;
HDR ; Header code
+1 SET VALMHDR(1)=""
+2 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+3 QUIT
+4 ;
HLP ;Help code
+1 NEW ORU,ORUPRMT,SUB,XQORM
+2 SET SUB="PXRMEGEDH"
+3 DO EN^VALM("PXRM EXTRACT HELP")
+4 QUIT
+5 ;
INIT ;Init
+1 SET VALMCNT=0
+2 QUIT
+3 ;
PEXIT ;PXRM EXCH MENU protocol exit code
+1 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+2 ;Reset after page up/down etc
+3 QUIT
+4 ;
ADD ;Add Rule
+1 NEW DA,DIC,DONE,DTOUT,DUOUT,DLAYGO,HED,Y
+2 SET HED="ADD EXTRACT COUNTING GROUP"
SET DONE=0
+3 WRITE IORESET,!
+4 FOR
Begin DoDot:1
+5 SET DIC="^PXRM(810.8,"
+6 ;Set the starting place for additions.
+7 DO SETSTART^PXRMCOPY(DIC)
+8 SET DIC(0)="AELMQ"
SET DLAYGO=810.8
+9 SET DIC("A")="Select EXTRACT COUNTING GROUP to add: "
+10 DO ^DIC
+11 IF $DATA(DUOUT)
SET DTOUT=1
+12 IF ($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+13 IF Y=-1
KILL DIC
SET DTOUT=1
QUIT
+14 IF $PIECE(Y,U,3)'=1
WRITE !,"This extract counting group name already exists"
QUIT
+15 SET DA=$PIECE(Y,U,1)
+16 ;Edit Extract Counting Group
+17 DO EDIT(DA)
+18 if $DATA(DA)
SET DONE=1
SET GROUP(DA)=""
End DoDot:1
if $DATA(DTOUT)
QUIT
if DONE
QUIT
+19 QUIT
+20 ;
EDIT(DA) ;Edit Rule
+1 IF '$$VEDIT^PXRMUTIL("^PXRM(810.8,",DA)
Begin DoDot:1
+2 WRITE !!,?5,"VA- and national class rules may not be edited"
HANG 2
+3 SET VALMBCK="R"
End DoDot:1
QUIT
+4 ;
+5 if '$$LOCK(DA)
QUIT
+6 WRITE IORESET
+7 NEW CS1,CS2,DIC,DIDEL,DIE,DR,DTOUT,DUOUT,ODA,Y
+8 ;Save checksum
+9 SET CS1=$$FILE^PXRMEXCS(810.8,DA)
+10 ;
+11 SET DIE="^PXRM(810.8,"
SET DIDEL=810.8
SET ODA=DA
SET DR="[PXRM EXTRACT COUNTING GROUP]"
+12 ;
+13 ;Edit extract counting group then unlock
+14 DO ^DIE
DO UNLOCK(ODA)
+15 ;Deleted ???
+16 IF '$DATA(DA)
SET VALMBCK="Q"
QUIT
+17 ;
+18 ;Update edit history
+19 Begin DoDot:1
+20 SET CS2=$$FILE^PXRMEXCS(810.8,DA)
if CS2=CS1
QUIT
if +CS2=0
QUIT
+21 DO SEHIST^PXRMUTIL(810.8,DIC,DA)
End DoDot:1
+22 ;
+23 SET VALMBCK="R"
+24 QUIT
+25 ;
EGEDIT ;Edit Rule
+1 DO EDIT(IEN)
if VALMBCK="Q"
QUIT
+2 ;
+3 ;Rebuild Workfile
+4 DO BLDLIST(IEN)
+5 QUIT
+6 ;
LOCK(DA) ;Lock the record
+1 LOCK +^PXRM(810.7,DA):DILOCKTM
IF $TEST
QUIT 1
+2 IF '$TEST
WRITE !!,?5,"Another user is editing this file, try later"
HANG 2
QUIT 0
+3 ;
SCREEN ;validate rule type
+1 QUIT
+2 ;
UNLOCK(DA) ;Unlock the record
+1 LOCK -^PXRM(810.7,DA)
+2 QUIT
