GMRCIRSN ;ALB/WTC - MANIPULATE REASON FOR REQUEST ON IFC ; Jan 09, 2025@09:45
;;3.0;CONSULT/REQUEST TRACKING;**201**;DEC 27, 1997;Build 7
;
Q ;don't start here!
;
RESEQNCE(IEN) ;
;
; Re-sequence reason for request OBX segments before filing.
;
; IEN = pointer to IFC REASON FOR REQUEST MAPPING file (#123.7)
;
; OBX segments are stored in ^TMP("GMRCIN",$J,"OBX",1,i). They are returned there after they are re-sequenced.
;
Q:$G(IEN)="" Q:'$D(^GMR(123.7,IEN)) ;
;
N DATAFLD,SEQUENCE,IEN2,N,X,IDX,NOTSTOR,ORDRNAME,M,IDX1 ;
;
K ^TMP("GMRCIRSN",$J) S ORDRNAME=$P(^GMR(123.7,IEN,0),U,1) ;
;
; Save order name from 1st OBX segment at top of resequenced list.
;
S IDX=0,X=$G(^TMP("GMRCIN",$J,"OBX",1,1)) I $$UP^XLFSTR($P(X,"|",5))=$$UP^XLFSTR(ORDRNAME) S IDX=IDX+1,^TMP("GMRCIRSN",$J,"OBX",1,IDX)=X K ^TMP("GMRCIN",$J,"OBX",1,1)
;
; Scan data fields in the desired sequence order.
;
S SEQUENCE=0 F S SEQUENCE=$O(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE)) Q:'SEQUENCE D ;
. S IEN2=0 F S IEN2=$O(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE,IEN2)) Q:'IEN2 S DATAFLD=$P(^GMR(123.7,IEN,1,IEN2,0),U,1),NOTSTOR=$P(^(0),U,3) D ;
.. W !,DATAFLD ;
.. ;
.. ; Find data field in the OBX segments and save it in the desired sequence.
.. ;
.. S N=0 F S N=$O(^TMP("GMRCIN",$J,"OBX",1,N)) Q:'N S X=^(N) I $$UP^XLFSTR($P($P(X,"|",5),":",1))=$$UP^XLFSTR(DATAFLD) D Q ;
... W !,"N",N,".",X ;
... I 'NOTSTOR S IDX=IDX+1,^TMP("GMRCIRSN",$J,"OBX",1,IDX)=X K ^TMP("GMRCIN",$J,"OBX",1,N) ;
... I NOTSTOR K ^TMP("GMRCIN",$J,"OBX",1,N) ; Delete data fields that are marked DO NOT STORE.
... ;
... ; If the preceding OBX seqment(s) do(es) not contain a data field, it's a comment about the data field. Include it.
... ;
... S M=N,IDX1=IDX F S M=$O(^TMP("GMRCIN",$J,"OBX",1,M),-1) Q:'M S X=^(M) Q:$P(X,"|",5)[":" D ;
.... W !,"M",M,".",X ;
.... I 'NOTSTOR S IDX1=IDX1-.1,^TMP("GMRCIRSN",$J,"OBX",1,IDX1)=X K ^TMP("GMRCIN",$J,"OBX",1,M) ;
.... I NOTSTOR K ^TMP("GMRCIN",$J,"OBX",1,M) ; Delete data fields that are marked DO NOT STORE.
... ;
... ; If the next OBX segment(s) do(es) not contain a data field, it's a continuation of the line before. Save it as well.
... ;
... F S N=$O(^TMP("GMRCIN",$J,"OBX",1,N)) Q:'N S X=^(N) Q:$P(X,"|",5)[":" Q:$E($P(X,"|",5),1)'=" " D ;
.... W !,"N",N,X ;
.... I 'NOTSTOR S IDX=IDX+1,^TMP("GMRCIRSN",$J,"OBX",1,IDX)=X K ^TMP("GMRCIN",$J,"OBX",1,N) ;
.... I NOTSTOR K ^TMP("GMRCIN",$J,"OBX",1,N) ; Delete data fields that are marked DO NOT STORE.
;
; Add unmatched reasons for request to the end.
;
S N=0 F S N=$O(^TMP("GMRCIN",$J,"OBX",1,N)) Q:'N S X=^(N),IDX=IDX+1,^TMP("GMRCIRSN",$J,"OBX",1,IDX)=X ;
;
; Re-sequence OBX-4.
;
S SEQUENCE=0 F IDX=1:1 S SEQUENCE=$O(^TMP("GMRCIRSN",$J,"OBX",1,SEQUENCE)) Q:'SEQUENCE S $P(^(SEQUENCE),"|",4)=IDX ;
;
; Restore re-sequenced OBX segments in ^TMP("GMRCIN",$J)
;
K ^TMP("GMRCIN",$J,"OBX",1) M ^TMP("GMRCIN",$J,"OBX",1)=^TMP("GMRCIRSN",$J,"OBX",1) ;
K ^TMP("GMRCIRSN",$J) ;
Q ;
;
LIST ;
;
; Formatted list of IFC REASON FOR REQUEST MAPPING file (#123.7) entry
;
N DIC,X,Y,IEN,DUOUT,DTOUT,POP,SEQUENCE,IEN2 ;
;
S DIC=123.7,DIC(0)="AEQM" D ^DIC Q:$D(DUOUT) Q:$D(DTOUT) Q:Y<0 S IEN=+Y ;
;
D ^%ZIS Q:POP ;
;
W !,"Order Name: ",$P(^GMR(123.7,IEN,0),U,1),! ;
W !,"Sequence",?10,"Data Field",?62,"Do not Store",!,"--------",?10,"------------------------------",?62,"------------",! ;
;
S SEQUENCE=0 F S SEQUENCE=$O(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE)) Q:'SEQUENCE S IEN2=0 F S IEN2=$O(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE,IEN2)) Q:'IEN2 D ;
. ;
. W $P(^GMR(123.7,IEN,1,IEN2,0),U,2),?10,$P(^(0),U,1),?62,$S($P(^(0),U,3):"YES",1:""),! ;
;
D ^%ZISC Q ;
;
LISTALL ;
;
; Formatted list of all IFC REASON FOR REQUEST MAPPING file (#123.7) entries
;
N DIC,X,Y,IEN,DUOUT,DTOUT,POP,SEQUENCE,IEN2 ;
;
D ^%ZIS Q:POP ;
;
S ORDRNAME="" F S ORDRNAME=$O(^GMR(123.7,"B",ORDRNAME)) Q:ORDRNAME="" S IEN=0 F S IEN=$O(^GMR(123.7,"B",ORDRNAME,IEN)) Q:'IEN D ;
. W !,"Order Name: ",$P(^GMR(123.7,IEN,0),U,1),! ;
. W !,"Sequence",?10,"Data Field",?62,"Do not Store",!,"--------",?10,"------------------------------",?62,"------------",! ;
. ;
. S SEQUENCE=0 F S SEQUENCE=$O(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE)) Q:'SEQUENCE S IEN2=0 F S IEN2=$O(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE,IEN2)) Q:'IEN2 D ;
.. ;
.. W $P(^GMR(123.7,IEN,1,IEN2,0),U,2),?10,$P(^(0),U,1),?62,$S($P(^(0),U,3):"YES",1:""),! ;
. W ! ;
;
D ^%ZISC Q ;
;
LOAD ;
;
; Add entry to #123.7. Code expects lines of text as follows: order name, data set name #1, #2, #3,... It looks for *** to end the sequence of data set names.
;
N ORDRNAME,X,LIST,I,DA,DIC,Y,N,DIK,COUNT ;
;
F R !,"ORDER NAME: ",ORDRNAME:DTIME Q:ORDRNAME="" W ! D ;
. ;
. S DA=$O(^GMR(123.7,"B",$E(ORDRNAME,1,30),0)) I DA,$P(^GMR(123.7,DA,0),U,1)=ORDRNAME W "...ALDREADY ON FILE.",! Q ;
. ;
. W !!,"ENTER OR PASTE ORDERED SEQUENCE OF DATA FIELDS: " ;
. K LIST F I=1:1 R X:DTIME Q:X="" Q:X?1"*"."*" S LIST(I)=$$RSTRIP(X) W ! ;
. W ! S COUNT=I-1 ;
. ;
. ; Add common data set names.
. ;
. F I=1:1:6 S COUNT=COUNT+1,LIST(COUNT)=$P("Delivery Method,Special Instructions,Opt. in for Item's final status,Facility,Point of Care,Address",",",I) ;
. ;
. K DA,DIC S X=ORDRNAME,DIC=^DIC(123.7,0,"GL"),DIC(0)="L" D FILE^DICN S DA=+Y ;
. ;
. S ^GMR(123.7,DA,1,0)="^123.71^"_(I-1)_"^"_(I-1) ;
. F N=1:1:COUNT S ^GMR(123.7,DA,1,N,0)=LIST(N)_U_N ;
. ;
. S DIK=^DIC(123.7,0,"GL") D IX^DIK ;
;
Q ;
;
RSTRIP(X) ;
;
Q:$E(X,$L(X))'=" " X ;
S X=$E(X,1,$L(X)-1) Q $$RSTRIP(X) ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIRSN 5734 printed Sep 23, 2025@19:22:09 Page 2
GMRCIRSN ;ALB/WTC - MANIPULATE REASON FOR REQUEST ON IFC ; Jan 09, 2025@09:45
+1 ;;3.0;CONSULT/REQUEST TRACKING;**201**;DEC 27, 1997;Build 7
+2 ;
+3 ;don't start here!
QUIT
+4 ;
RESEQNCE(IEN) ;
+1 ;
+2 ; Re-sequence reason for request OBX segments before filing.
+3 ;
+4 ; IEN = pointer to IFC REASON FOR REQUEST MAPPING file (#123.7)
+5 ;
+6 ; OBX segments are stored in ^TMP("GMRCIN",$J,"OBX",1,i). They are returned there after they are re-sequenced.
+7 ;
+8 ;
if $GET(IEN)=""
QUIT
if '$DATA(^GMR(123.7,IEN))
QUIT
+9 ;
+10 ;
NEW DATAFLD,SEQUENCE,IEN2,N,X,IDX,NOTSTOR,ORDRNAME,M,IDX1
+11 ;
+12 ;
KILL ^TMP("GMRCIRSN",$JOB)
SET ORDRNAME=$PIECE(^GMR(123.7,IEN,0),U,1)
+13 ;
+14 ; Save order name from 1st OBX segment at top of resequenced list.
+15 ;
+16 SET IDX=0
SET X=$GET(^TMP("GMRCIN",$JOB,"OBX",1,1))
IF $$UP^XLFSTR($PIECE(X,"|",5))=$$UP^XLFSTR(ORDRNAME)
SET IDX=IDX+1
SET ^TMP("GMRCIRSN",$JOB,"OBX",1,IDX)=X
KILL ^TMP("GMRCIN",$JOB,"OBX",1,1)
+17 ;
+18 ; Scan data fields in the desired sequence order.
+19 ;
+20 ;
SET SEQUENCE=0
FOR
SET SEQUENCE=$ORDER(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE))
if 'SEQUENCE
QUIT
Begin DoDot:1
+21 ;
SET IEN2=0
FOR
SET IEN2=$ORDER(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE,IEN2))
if 'IEN2
QUIT
SET DATAFLD=$PIECE(^GMR(123.7,IEN,1,IEN2,0),U,1)
SET NOTSTOR=$PIECE(^(0),U,3)
Begin DoDot:2
+22 ;
WRITE !,DATAFLD
+23 ;
+24 ; Find data field in the OBX segments and save it in the desired sequence.
+25 ;
+26 ;
SET N=0
FOR
SET N=$ORDER(^TMP("GMRCIN",$JOB,"OBX",1,N))
if 'N
QUIT
SET X=^(N)
IF $$UP^XLFSTR($PIECE($PIECE(X,"|",5),":",1))=$$UP^XLFSTR(DATAFLD)
Begin DoDot:3
+27 ;
WRITE !,"N",N,".",X
+28 ;
IF 'NOTSTOR
SET IDX=IDX+1
SET ^TMP("GMRCIRSN",$JOB,"OBX",1,IDX)=X
KILL ^TMP("GMRCIN",$JOB,"OBX",1,N)
+29 ; Delete data fields that are marked DO NOT STORE.
IF NOTSTOR
KILL ^TMP("GMRCIN",$JOB,"OBX",1,N)
+30 ;
+31 ; If the preceding OBX seqment(s) do(es) not contain a data field, it's a comment about the data field. Include it.
+32 ;
+33 ;
SET M=N
SET IDX1=IDX
FOR
SET M=$ORDER(^TMP("GMRCIN",$JOB,"OBX",1,M),-1)
if 'M
QUIT
SET X=^(M)
if $PIECE(X,"|",5)["
QUIT
Begin DoDot:4
+34 ;
WRITE !,"M",M,".",X
+35 ;
IF 'NOTSTOR
SET IDX1=IDX1-.1
SET ^TMP("GMRCIRSN",$JOB,"OBX",1,IDX1)=X
KILL ^TMP("GMRCIN",$JOB,"OBX",1,M)
+36 ; Delete data fields that are marked DO NOT STORE.
IF NOTSTOR
KILL ^TMP("GMRCIN",$JOB,"OBX",1,M)
End DoDot:4
+37 ;
+38 ; If the next OBX segment(s) do(es) not contain a data field, it's a continuation of the line before. Save it as well.
+39 ;
+40 ;
FOR
SET N=$ORDER(^TMP("GMRCIN",$JOB,"OBX",1,N))
if 'N
QUIT
SET X=^(N)
if $PIECE(X,"|",5)["
QUIT
if $EXTRACT($PIECE(X,"|",5),1)'=" "
QUIT
Begin DoDot:4
+41 ;
WRITE !,"N",N,X
+42 ;
IF 'NOTSTOR
SET IDX=IDX+1
SET ^TMP("GMRCIRSN",$JOB,"OBX",1,IDX)=X
KILL ^TMP("GMRCIN",$JOB,"OBX",1,N)
+43 ; Delete data fields that are marked DO NOT STORE.
IF NOTSTOR
KILL ^TMP("GMRCIN",$JOB,"OBX",1,N)
End DoDot:4
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+44 ;
+45 ; Add unmatched reasons for request to the end.
+46 ;
+47 ;
SET N=0
FOR
SET N=$ORDER(^TMP("GMRCIN",$JOB,"OBX",1,N))
if 'N
QUIT
SET X=^(N)
SET IDX=IDX+1
SET ^TMP("GMRCIRSN",$JOB,"OBX",1,IDX)=X
+48 ;
+49 ; Re-sequence OBX-4.
+50 ;
+51 ;
SET SEQUENCE=0
FOR IDX=1:1
SET SEQUENCE=$ORDER(^TMP("GMRCIRSN",$JOB,"OBX",1,SEQUENCE))
if 'SEQUENCE
QUIT
SET $PIECE(^(SEQUENCE),"|",4)=IDX
+52 ;
+53 ; Restore re-sequenced OBX segments in ^TMP("GMRCIN",$J)
+54 ;
+55 ;
KILL ^TMP("GMRCIN",$JOB,"OBX",1)
MERGE ^TMP("GMRCIN",$JOB,"OBX",1)=^TMP("GMRCIRSN",$JOB,"OBX",1)
+56 ;
KILL ^TMP("GMRCIRSN",$JOB)
+57 ;
QUIT
+58 ;
LIST ;
+1 ;
+2 ; Formatted list of IFC REASON FOR REQUEST MAPPING file (#123.7) entry
+3 ;
+4 ;
NEW DIC,X,Y,IEN,DUOUT,DTOUT,POP,SEQUENCE,IEN2
+5 ;
+6 ;
SET DIC=123.7
SET DIC(0)="AEQM"
DO ^DIC
if $DATA(DUOUT)
QUIT
if $DATA(DTOUT)
QUIT
if Y<0
QUIT
SET IEN=+Y
+7 ;
+8 ;
DO ^%ZIS
if POP
QUIT
+9 ;
+10 ;
WRITE !,"Order Name: ",$PIECE(^GMR(123.7,IEN,0),U,1),!
+11 ;
WRITE !,"Sequence",?10,"Data Field",?62,"Do not Store",!,"--------",?10,"------------------------------",?62,"------------",!
+12 ;
+13 ;
SET SEQUENCE=0
FOR
SET SEQUENCE=$ORDER(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE))
if 'SEQUENCE
QUIT
SET IEN2=0
FOR
SET IEN2=$ORDER(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE,IEN2))
if 'IEN2
QUIT
Begin DoDot:1
+14 ;
+15 ;
WRITE $PIECE(^GMR(123.7,IEN,1,IEN2,0),U,2),?10,$PIECE(^(0),U,1),?62,$SELECT($PIECE(^(0),U,3):"YES",1:""),!
End DoDot:1
+16 ;
+17 ;
DO ^%ZISC
QUIT
+18 ;
LISTALL ;
+1 ;
+2 ; Formatted list of all IFC REASON FOR REQUEST MAPPING file (#123.7) entries
+3 ;
+4 ;
NEW DIC,X,Y,IEN,DUOUT,DTOUT,POP,SEQUENCE,IEN2
+5 ;
+6 ;
DO ^%ZIS
if POP
QUIT
+7 ;
+8 ;
SET ORDRNAME=""
FOR
SET ORDRNAME=$ORDER(^GMR(123.7,"B",ORDRNAME))
if ORDRNAME=""
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(^GMR(123.7,"B",ORDRNAME,IEN))
if 'IEN
QUIT
Begin DoDot:1
+9 ;
WRITE !,"Order Name: ",$PIECE(^GMR(123.7,IEN,0),U,1),!
+10 ;
WRITE !,"Sequence",?10,"Data Field",?62,"Do not Store",!,"--------",?10,"------------------------------",?62,"------------",!
+11 ;
+12 ;
SET SEQUENCE=0
FOR
SET SEQUENCE=$ORDER(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE))
if 'SEQUENCE
QUIT
SET IEN2=0
FOR
SET IEN2=$ORDER(^GMR(123.7,IEN,1,"SEQUENCE",SEQUENCE,IEN2))
if 'IEN2
QUIT
Begin DoDot:2
+13 ;
+14 ;
WRITE $PIECE(^GMR(123.7,IEN,1,IEN2,0),U,2),?10,$PIECE(^(0),U,1),?62,$SELECT($PIECE(^(0),U,3):"YES",1:""),!
End DoDot:2
+15 ;
WRITE !
End DoDot:1
+16 ;
+17 ;
DO ^%ZISC
QUIT
+18 ;
LOAD ;
+1 ;
+2 ; Add entry to #123.7. Code expects lines of text as follows: order name, data set name #1, #2, #3,... It looks for *** to end the sequence of data set names.
+3 ;
+4 ;
NEW ORDRNAME,X,LIST,I,DA,DIC,Y,N,DIK,COUNT
+5 ;
+6 ;
FOR
READ !,"ORDER NAME: ",ORDRNAME:DTIME
if ORDRNAME=""
QUIT
WRITE !
Begin DoDot:1
+7 ;
+8 ;
SET DA=$ORDER(^GMR(123.7,"B",$EXTRACT(ORDRNAME,1,30),0))
IF DA
IF $PIECE(^GMR(123.7,DA,0),U,1)=ORDRNAME
WRITE "...ALDREADY ON FILE.",!
QUIT
+9 ;
+10 ;
WRITE !!,"ENTER OR PASTE ORDERED SEQUENCE OF DATA FIELDS: "
+11 ;
KILL LIST
FOR I=1:1
READ X:DTIME
if X=""
QUIT
if X?1"*"."*"
QUIT
SET LIST(I)=$$RSTRIP(X)
WRITE !
+12 ;
WRITE !
SET COUNT=I-1
+13 ;
+14 ; Add common data set names.
+15 ;
+16 ;
FOR I=1:1:6
SET COUNT=COUNT+1
SET LIST(COUNT)=$PIECE("Delivery Method,Special Instructions,Opt. in for Item's final status,Facility,Point of Care,Address",",",I)
+17 ;
+18 ;
KILL DA,DIC
SET X=ORDRNAME
SET DIC=^DIC(123.7,0,"GL")
SET DIC(0)="L"
DO FILE^DICN
SET DA=+Y
+19 ;
+20 ;
SET ^GMR(123.7,DA,1,0)="^123.71^"_(I-1)_"^"_(I-1)
+21 ;
FOR N=1:1:COUNT
SET ^GMR(123.7,DA,1,N,0)=LIST(N)_U_N
+22 ;
+23 ;
SET DIK=^DIC(123.7,0,"GL")
DO IX^DIK
End DoDot:1
+24 ;
+25 ;
QUIT
+26 ;
RSTRIP(X) ;
+1 ;
+2 ;
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT X
+3 ;
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
QUIT $$RSTRIP(X)
+4 ;
