GMRCAD31 ;SLC/JFR - admin corrections on cons. activities; 2/19/03 14:09
;;3.0;CONSULT/REQUEST TRACKING;**32**;DEC 27, 1997
EN ;Start prompting and prepare to build a list
N GMRCIEN
S GMRCIEN=$$GETCSLT
I 'GMRCIEN W !,"No Consult selected." Q
I '$$CKACTS(GMRCIEN) D G EN
. W !,"The request has no activities meeting editing criteria"
. H 2
D BLDLST(GMRCIEN)
D EN^VALM("GMRC ADM31")
Q
;
GETCSLT() ;
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
D EN^DDIOL("You may only select IFC requests ordered at your facility")
D EN^DDIOL(" ")
S DIR(0)="PAO^123"
S DIR("?")="Select an inter-facility request being performed elsewhere"
S DIR("A")="Select Consult #: "
S DIR("S")="I $P($G(^GMR(123,+Y,12)),U,5)=""P"""
D ^DIR
I '$G(Y) Q ""
Q +Y
Q
;
NEWCSLT ; select a new consult to work on
D FULL^VALM1
N GMRCIEN
S GMRCIEN=$$GETCSLT
I 'GMRCIEN D D INIT Q
. N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
. S DIR(0)="E" D ^DIR
. Q
I '$$CKACTS(GMRCIEN) D D INIT Q
. W !,"The request has no activities meeting editing criteria"
D EXIT,BLDLST(GMRCIEN),INIT
Q
;
SELACT ; choose which action to edit
D FULL^VALM1
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y,GMRCO
D EN^DDIOL("You may only select one of the listed activities.")
D EN^DDIOL(" ")
S DIR(0)="NAO^2:50"
S DIR("A")="Select an activity from the list by number: "
D ^DIR
I $D(DIRUT) S VALMBCK="R" Q
I '$D(^TMP("GMRCADM",$J,"B",+Y)) D G SELACT
. D EN^DDIOL("That is not a listed activity",,"!!?5")
S GMRCO=$G(^TMP("GMRCADM",$J,"CSLT"))
D FIX(GMRCO,+Y)
D EXIT,BLDLST(GMRCO),INIT
S VALMBCK="R"
Q
;
BLDLST(GMRCDA) ;build the list for LM
; Input:
; GMRCDA = ien from file 123
;
K ^TMP("GMRCADM",$J)
N PTNM,PTSSN,REMSIT,REMNUM,GMRCCT,TAB
S ^TMP("GMRCADM",$J,"CSLT")=GMRCDA
S GMRCCT=1,TAB=$$REPEAT^XLFSTR(" ",29)
S PTNM="Patient name: "_$$GET1^DIQ(123,GMRCDA,.02,"E")
S PTSSN="SSN: "_$$GET1^DIQ(2,$P(^GMR(123,GMRCDA,0),U,2),.09)
S REMSIT="Receiving Site: "
S REMSIT=REMSIT_$$GET1^DIQ(4,$P(^GMR(123,GMRCDA,0),U,23),.01)
S REMNUM="Remote Consult #: "_$P(^GMR(123,GMRCDA,0),U,22)
S ^TMP("GMRCADM",$J,GMRCCT,0)="Consult #: "_GMRCDA
S GMRCCT=GMRCCT+1
S ^TMP("GMRCADM",$J,GMRCCT,0)=PTNM_" "_PTSSN
S GMRCCT=GMRCCT+1
S ^TMP("GMRCADM",$J,GMRCCT,0)=REMSIT_" "_REMNUM
S GMRCCT=GMRCCT+1
S ^TMP("GMRCADM",$J,GMRCCT,0)="",GMRCCT=GMRCCT+1
S ^TMP("GMRCADM",$J,GMRCCT,0)="Facility",GMRCCT=GMRCCT+1
S ^TMP("GMRCADM",$J,GMRCCT,0)=" Activity"_$E(TAB,1,16)_"Date/Time/Zone"_$E(TAB,1,6)_"Responsible Person"_$E(TAB,1,2)_"Entered By",GMRCCT=GMRCCT+1
S ^TMP("GMRCADM",$J,GMRCCT,0)=$$REPEAT^XLFSTR("-",79)
S GMRCCT=GMRCCT+1
N ACTV
S ACTV=0
F S ACTV=$O(^GMR(123,GMRCDA,40,ACTV)) Q:'ACTV D
. N ACTYPE
. S ACTYPE=$P(^GMR(123,GMRCDA,40,ACTV,0),U,2)
. Q:ACTYPE'=17&(ACTYPE'=4) ;only FWD and SF are affected
. Q:'$D(^GMR(123,GMRCDA,40,ACTV,2)) ;only remote activities
. Q:'$O(^GMR(123,GMRCDA,40,ACTV,1,1))
. S ^TMP("GMRCADM",$J,"B",ACTV)=GMRCCT
. S ^TMP("GMRCADM",$J,GMRCCT,0)=" Act. #: "_ACTV,GMRCCT=GMRCCT+1
. D BLDALN^GMRCSLM4(GMRCDA,ACTV)
. M ^TMP("GMRCADM",$J)=^TMP("GMRCR",$J,"DT")
. K ^TMP("GMRCR",$J,"DT")
. S ^TMP("GMRCADM",$J,GMRCCT,0)="",GMRCCT=GMRCCT+1
. Q
Q
;
INIT ;
S VALMCNT=$O(^TMP("GMRCADM",$J," "),-1)
S VALMBG=1
S VALMBCK="R"
Q
;
EXIT ;
K ^TMP("GMRCADM",$J)
S VALMBCK="Q"
Q
;
HDR ;
S VALMHDR(1)=$$CJ^XLFSTR(("Consult #:"_^TMP("GMRCADM",$J,"CSLT")),80)
Q
CKACTS(CSLT) ;assure that there is at least one activity meeting criteria
; Input:
; CSLT = ien from file 123
;
N ACTV,OK
S ACTV=0,OK=0
F S ACTV=$O(^GMR(123,CSLT,40,ACTV)) Q:'ACTV!(OK=1) D
. N ACTYPE
. S ACTYPE=$P(^GMR(123,CSLT,40,ACTV,0),U,2)
. I ACTYPE=17 S OK=1 ; FWD action
. I ACTYPE=4 S OK=1 ; SF action
. I OK,'$D(^GMR(123,CSLT,40,ACTV,2)) S OK=0 ;only remote activities
. I OK,'$O(^GMR(123,CSLT,40,ACTV,1,1)) S OK=0 ;only those with comments
Q OK
;
FIX(GMRCDA,GMRCACT) ;do the admin correction on bad IFC comments
; GMRCDA = ien from file 123
; GMRCACT = ien within 40 multiple for activity
;
I '$D(^GMR(123,GMRCDA,40,1)) D Q
. W !,"No comment there to correct"
K ^TMP("GMRCOCMT",$J)
M ^TMP("GMRCOCMT",$J)=^GMR(123,GMRCDA,40,GMRCACT,1)
W !!
N DIE,DR,DA,CHGD
S CHGD=0
S DA=GMRCACT,DA(1)=GMRCDA,DR=5,DIE="^GMR(123,"_DA(1)_",40,"
D ^DIE
I $O(^GMR(123,GMRCDA,40,GMRCACT,1," "),-1)'=$O(^TMP("GMRCOCMT",$J," "),-1) S CHGD=1
I 'CHGD D
. N I S I=0
. F S I=$O(^GMR(123,GMRCDA,40,GMRCACT,1,I)) Q:'I!(CHGD) D
.. I ^GMR(123,GMRCDA,40,GMRCACT,1,I,0)'=^TMP("GMRCOCMT",$J,I,0) S CHGD=1
.. Q
I 'CHGD W !,"No comment modification made!",!
I CHGD D AUDIT(GMRCDA,GMRCACT,$NA(^TMP("GMRCOCMT",$J)))
K ^TMP("GMRCOCMT",$J)
Q
;
AUDIT(GMRCO,GMRCAC,ARRAY) ;make new audit trail activity w/old and new
;Input:
; GMRCO = ien from file 123
; GMRCAC = IEN WITHIN 40 MULTIPLE
; ARRAY = array containing the old comment
N GMRCA,GMRCAD,GMRCMT,GMRCDA,DA,NUM,I
N ACTYPE,ACTWHO,ACTRESP,ACTWHEN
I '$G(GMRCO) Q
; load up particulars about edited activity, then load old comment
; then load up new comment in GMRCMT local array
S ACTYPE=$$GET1^DIQ(123.1,$P(^GMR(123,GMRCO,40,GMRCAC,0),U,2),.01)
S ACTWHO=$P(^GMR(123,GMRCO,40,GMRCAC,2),U)
S ACTRESP=$P(^GMR(123,GMRCO,40,GMRCAC,2),U,2)
D ;GET VALUE OF ACTWHEN
. N X
. S X=$P(^GMR(123,GMRCO,40,GMRCAC,2),U,5) D REGDTM^GMRCU
. S ACTWHEN=X_" "_$P(^GMR(123,GMRCO,40,GMRCAC,2),U,3)
S NUM=1
S GMRCMT(NUM)=" ",NUM=NUM+1
S GMRCMT(NUM)="The "_ACTYPE_" action, added "_ACTWHEN_" by",NUM=NUM+1
S GMRCMT(NUM)=ACTWHO_" "_$S($L(ACTRESP):("for "_ACTRESP),1:"")_","
S GMRCMT(NUM)=GMRCMT(NUM)_" has been administratively corrected."
S NUM=NUM+1,GMRCMT(NUM)=" ",NUM=NUM+1
S GMRCMT(NUM)="The comment was corrected from:",NUM=NUM+1
S GMRCMT(NUM)=" ",NUM=NUM+1
S I=0 ;load up old comment
F S I=$O(^TMP("GMRCOCMT",$J,I)) Q:'I D
. S GMRCMT(NUM)=^TMP("GMRCOCMT",$J,I,0),NUM=NUM+1
S GMRCMT(NUM)=" ",NUM=NUM+1
S GMRCMT(NUM)="The comment was corrected to: ",NUM=NUM+1
S GMRCMT(NUM)=" ",NUM=NUM+1
S I=0 ;load up current comment
F S I=$O(^GMR(123,GMRCO,40,GMRCAC,1,I)) Q:'I D
. S GMRCMT(NUM)=^GMR(123,GMRCO,40,GMRCAC,1,I,0)
. S NUM=NUM+1
;
; file admin correct comment
S GMRCDA=$$SETDA^GMRCGUIB ; get new activity ien
S GMRCA=26,GMRCAD=$$NOW^XLFDT,DA=GMRCDA
D SETCOM^GMRCGUIB(.GMRCMT,DUZ)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCAD31 6427 printed Sep 23, 2025@19:20:59 Page 2
GMRCAD31 ;SLC/JFR - admin corrections on cons. activities; 2/19/03 14:09
+1 ;;3.0;CONSULT/REQUEST TRACKING;**32**;DEC 27, 1997
EN ;Start prompting and prepare to build a list
+1 NEW GMRCIEN
+2 SET GMRCIEN=$$GETCSLT
+3 IF 'GMRCIEN
WRITE !,"No Consult selected."
QUIT
+4 IF '$$CKACTS(GMRCIEN)
Begin DoDot:1
+5 WRITE !,"The request has no activities meeting editing criteria"
+6 HANG 2
End DoDot:1
GOTO EN
+7 DO BLDLST(GMRCIEN)
+8 DO EN^VALM("GMRC ADM31")
+9 QUIT
+10 ;
GETCSLT() ;
+1 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+2 DO EN^DDIOL("You may only select IFC requests ordered at your facility")
+3 DO EN^DDIOL(" ")
+4 SET DIR(0)="PAO^123"
+5 SET DIR("?")="Select an inter-facility request being performed elsewhere"
+6 SET DIR("A")="Select Consult #: "
+7 SET DIR("S")="I $P($G(^GMR(123,+Y,12)),U,5)=""P"""
+8 DO ^DIR
+9 IF '$GET(Y)
QUIT ""
+10 QUIT +Y
+11 QUIT
+12 ;
NEWCSLT ; select a new consult to work on
+1 DO FULL^VALM1
+2 NEW GMRCIEN
+3 SET GMRCIEN=$$GETCSLT
+4 IF 'GMRCIEN
Begin DoDot:1
+5 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+6 SET DIR(0)="E"
DO ^DIR
+7 QUIT
End DoDot:1
DO INIT
QUIT
+8 IF '$$CKACTS(GMRCIEN)
Begin DoDot:1
+9 WRITE !,"The request has no activities meeting editing criteria"
End DoDot:1
DO INIT
QUIT
+10 DO EXIT
DO BLDLST(GMRCIEN)
DO INIT
+11 QUIT
+12 ;
SELACT ; choose which action to edit
+1 DO FULL^VALM1
+2 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y,GMRCO
+3 DO EN^DDIOL("You may only select one of the listed activities.")
+4 DO EN^DDIOL(" ")
+5 SET DIR(0)="NAO^2:50"
+6 SET DIR("A")="Select an activity from the list by number: "
+7 DO ^DIR
+8 IF $DATA(DIRUT)
SET VALMBCK="R"
QUIT
+9 IF '$DATA(^TMP("GMRCADM",$JOB,"B",+Y))
Begin DoDot:1
+10 DO EN^DDIOL("That is not a listed activity",,"!!?5")
End DoDot:1
GOTO SELACT
+11 SET GMRCO=$GET(^TMP("GMRCADM",$JOB,"CSLT"))
+12 DO FIX(GMRCO,+Y)
+13 DO EXIT
DO BLDLST(GMRCO)
DO INIT
+14 SET VALMBCK="R"
+15 QUIT
+16 ;
BLDLST(GMRCDA) ;build the list for LM
+1 ; Input:
+2 ; GMRCDA = ien from file 123
+3 ;
+4 KILL ^TMP("GMRCADM",$JOB)
+5 NEW PTNM,PTSSN,REMSIT,REMNUM,GMRCCT,TAB
+6 SET ^TMP("GMRCADM",$JOB,"CSLT")=GMRCDA
+7 SET GMRCCT=1
SET TAB=$$REPEAT^XLFSTR(" ",29)
+8 SET PTNM="Patient name: "_$$GET1^DIQ(123,GMRCDA,.02,"E")
+9 SET PTSSN="SSN: "_$$GET1^DIQ(2,$PIECE(^GMR(123,GMRCDA,0),U,2),.09)
+10 SET REMSIT="Receiving Site: "
+11 SET REMSIT=REMSIT_$$GET1^DIQ(4,$PIECE(^GMR(123,GMRCDA,0),U,23),.01)
+12 SET REMNUM="Remote Consult #: "_$PIECE(^GMR(123,GMRCDA,0),U,22)
+13 SET ^TMP("GMRCADM",$JOB,GMRCCT,0)="Consult #: "_GMRCDA
+14 SET GMRCCT=GMRCCT+1
+15 SET ^TMP("GMRCADM",$JOB,GMRCCT,0)=PTNM_" "_PTSSN
+16 SET GMRCCT=GMRCCT+1
+17 SET ^TMP("GMRCADM",$JOB,GMRCCT,0)=REMSIT_" "_REMNUM
+18 SET GMRCCT=GMRCCT+1
+19 SET ^TMP("GMRCADM",$JOB,GMRCCT,0)=""
SET GMRCCT=GMRCCT+1
+20 SET ^TMP("GMRCADM",$JOB,GMRCCT,0)="Facility"
SET GMRCCT=GMRCCT+1
+21 SET ^TMP("GMRCADM",$JOB,GMRCCT,0)=" Activity"_$EXTRACT(TAB,1,16)_"Date/Time/Zone"_$EXTRACT(TAB,1,6)_"Responsible Person"_$EXTRACT(TAB,1,2)_"Entered By"
SET GMRCCT=GMRCCT+1
+22 SET ^TMP("GMRCADM",$JOB,GMRCCT,0)=$$REPEAT^XLFSTR("-",79)
+23 SET GMRCCT=GMRCCT+1
+24 NEW ACTV
+25 SET ACTV=0
+26 FOR
SET ACTV=$ORDER(^GMR(123,GMRCDA,40,ACTV))
if 'ACTV
QUIT
Begin DoDot:1
+27 NEW ACTYPE
+28 SET ACTYPE=$PIECE(^GMR(123,GMRCDA,40,ACTV,0),U,2)
+29 ;only FWD and SF are affected
if ACTYPE'=17&(ACTYPE'=4)
QUIT
+30 ;only remote activities
if '$DATA(^GMR(123,GMRCDA,40,ACTV,2))
QUIT
+31 if '$ORDER(^GMR(123,GMRCDA,40,ACTV,1,1))
QUIT
+32 SET ^TMP("GMRCADM",$JOB,"B",ACTV)=GMRCCT
+33 SET ^TMP("GMRCADM",$JOB,GMRCCT,0)=" Act. #: "_ACTV
SET GMRCCT=GMRCCT+1
+34 DO BLDALN^GMRCSLM4(GMRCDA,ACTV)
+35 MERGE ^TMP("GMRCADM",$JOB)=^TMP("GMRCR",$JOB,"DT")
+36 KILL ^TMP("GMRCR",$JOB,"DT")
+37 SET ^TMP("GMRCADM",$JOB,GMRCCT,0)=""
SET GMRCCT=GMRCCT+1
+38 QUIT
End DoDot:1
+39 QUIT
+40 ;
INIT ;
+1 SET VALMCNT=$ORDER(^TMP("GMRCADM",$JOB," "),-1)
+2 SET VALMBG=1
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
EXIT ;
+1 KILL ^TMP("GMRCADM",$JOB)
+2 SET VALMBCK="Q"
+3 QUIT
+4 ;
HDR ;
+1 SET VALMHDR(1)=$$CJ^XLFSTR(("Consult #:"_^TMP("GMRCADM",$JOB,"CSLT")),80)
+2 QUIT
CKACTS(CSLT) ;assure that there is at least one activity meeting criteria
+1 ; Input:
+2 ; CSLT = ien from file 123
+3 ;
+4 NEW ACTV,OK
+5 SET ACTV=0
SET OK=0
+6 FOR
SET ACTV=$ORDER(^GMR(123,CSLT,40,ACTV))
if 'ACTV!(OK=1)
QUIT
Begin DoDot:1
+7 NEW ACTYPE
+8 SET ACTYPE=$PIECE(^GMR(123,CSLT,40,ACTV,0),U,2)
+9 ; FWD action
IF ACTYPE=17
SET OK=1
+10 ; SF action
IF ACTYPE=4
SET OK=1
+11 ;only remote activities
IF OK
IF '$DATA(^GMR(123,CSLT,40,ACTV,2))
SET OK=0
+12 ;only those with comments
IF OK
IF '$ORDER(^GMR(123,CSLT,40,ACTV,1,1))
SET OK=0
End DoDot:1
+13 QUIT OK
+14 ;
FIX(GMRCDA,GMRCACT) ;do the admin correction on bad IFC comments
+1 ; GMRCDA = ien from file 123
+2 ; GMRCACT = ien within 40 multiple for activity
+3 ;
+4 IF '$DATA(^GMR(123,GMRCDA,40,1))
Begin DoDot:1
+5 WRITE !,"No comment there to correct"
End DoDot:1
QUIT
+6 KILL ^TMP("GMRCOCMT",$JOB)
+7 MERGE ^TMP("GMRCOCMT",$JOB)=^GMR(123,GMRCDA,40,GMRCACT,1)
+8 WRITE !!
+9 NEW DIE,DR,DA,CHGD
+10 SET CHGD=0
+11 SET DA=GMRCACT
SET DA(1)=GMRCDA
SET DR=5
SET DIE="^GMR(123,"_DA(1)_",40,"
+12 DO ^DIE
+13 IF $ORDER(^GMR(123,GMRCDA,40,GMRCACT,1," "),-1)'=$ORDER(^TMP("GMRCOCMT",$JOB," "),-1)
SET CHGD=1
+14 IF 'CHGD
Begin DoDot:1
+15 NEW I
SET I=0
+16 FOR
SET I=$ORDER(^GMR(123,GMRCDA,40,GMRCACT,1,I))
if 'I!(CHGD)
QUIT
Begin DoDot:2
+17 IF ^GMR(123,GMRCDA,40,GMRCACT,1,I,0)'=^TMP("GMRCOCMT",$JOB,I,0)
SET CHGD=1
+18 QUIT
End DoDot:2
End DoDot:1
+19 IF 'CHGD
WRITE !,"No comment modification made!",!
+20 IF CHGD
DO AUDIT(GMRCDA,GMRCACT,$NAME(^TMP("GMRCOCMT",$JOB)))
+21 KILL ^TMP("GMRCOCMT",$JOB)
+22 QUIT
+23 ;
AUDIT(GMRCO,GMRCAC,ARRAY) ;make new audit trail activity w/old and new
+1 ;Input:
+2 ; GMRCO = ien from file 123
+3 ; GMRCAC = IEN WITHIN 40 MULTIPLE
+4 ; ARRAY = array containing the old comment
+5 NEW GMRCA,GMRCAD,GMRCMT,GMRCDA,DA,NUM,I
+6 NEW ACTYPE,ACTWHO,ACTRESP,ACTWHEN
+7 IF '$GET(GMRCO)
QUIT
+8 ; load up particulars about edited activity, then load old comment
+9 ; then load up new comment in GMRCMT local array
+10 SET ACTYPE=$$GET1^DIQ(123.1,$PIECE(^GMR(123,GMRCO,40,GMRCAC,0),U,2),.01)
+11 SET ACTWHO=$PIECE(^GMR(123,GMRCO,40,GMRCAC,2),U)
+12 SET ACTRESP=$PIECE(^GMR(123,GMRCO,40,GMRCAC,2),U,2)
+13 ;GET VALUE OF ACTWHEN
Begin DoDot:1
+14 NEW X
+15 SET X=$PIECE(^GMR(123,GMRCO,40,GMRCAC,2),U,5)
DO REGDTM^GMRCU
+16 SET ACTWHEN=X_" "_$PIECE(^GMR(123,GMRCO,40,GMRCAC,2),U,3)
End DoDot:1
+17 SET NUM=1
+18 SET GMRCMT(NUM)=" "
SET NUM=NUM+1
+19 SET GMRCMT(NUM)="The "_ACTYPE_" action, added "_ACTWHEN_" by"
SET NUM=NUM+1
+20 SET GMRCMT(NUM)=ACTWHO_" "_$SELECT($LENGTH(ACTRESP):("for "_ACTRESP),1:"")_","
+21 SET GMRCMT(NUM)=GMRCMT(NUM)_" has been administratively corrected."
+22 SET NUM=NUM+1
SET GMRCMT(NUM)=" "
SET NUM=NUM+1
+23 SET GMRCMT(NUM)="The comment was corrected from:"
SET NUM=NUM+1
+24 SET GMRCMT(NUM)=" "
SET NUM=NUM+1
+25 ;load up old comment
SET I=0
+26 FOR
SET I=$ORDER(^TMP("GMRCOCMT",$JOB,I))
if 'I
QUIT
Begin DoDot:1
+27 SET GMRCMT(NUM)=^TMP("GMRCOCMT",$JOB,I,0)
SET NUM=NUM+1
End DoDot:1
+28 SET GMRCMT(NUM)=" "
SET NUM=NUM+1
+29 SET GMRCMT(NUM)="The comment was corrected to: "
SET NUM=NUM+1
+30 SET GMRCMT(NUM)=" "
SET NUM=NUM+1
+31 ;load up current comment
SET I=0
+32 FOR
SET I=$ORDER(^GMR(123,GMRCO,40,GMRCAC,1,I))
if 'I
QUIT
Begin DoDot:1
+33 SET GMRCMT(NUM)=^GMR(123,GMRCO,40,GMRCAC,1,I,0)
+34 SET NUM=NUM+1
End DoDot:1
+35 ;
+36 ; file admin correct comment
+37 ; get new activity ien
SET GMRCDA=$$SETDA^GMRCGUIB
+38 SET GMRCA=26
SET GMRCAD=$$NOW^XLFDT
SET DA=GMRCDA
+39 DO SETCOM^GMRCGUIB(.GMRCMT,DUZ)
+40 QUIT
