GMTSRM3 ; SLC/DLT - Create/Modify - Selection Items ; 08/27/2002
;;2.7;Health Summary;**56,62,63**;Oct 20, 1995
;
; External References
; DBIA 2160 ^XUTL("OR")
; DBIA 67 ^LAB(60,
; DBIA 3137 EN^ORUS
;
EN ; Entry Logic for Selection Items
N GMTSN W !!,$S($O(^GMT(142,DA(1),1,DA,1,0)):"Current selection items are: ",1:"No selection items chosen.")
S GMTSN=0 F S GMTSN=$O(^GMT(142,DA(1),1,DA,1,GMTSN)) Q:+GMTSN'>0 S GMTSN(0)=^(GMTSN,0) D SHOWSEL
W !!,"Select new items one at a time in the sequence you want them displayed."
W !,"You may select " I SELCNT="" W "any number of items.",!
E W "up to ",SELCNT," items.",!
Q
SHOWSEL ; Writes Current Selection Items
W ?30,$P(@("^"_$P(GMTSN(0),";",2)_+GMTSN(0)_",0)"),U),!
Q
EXIT ; Exit Logic for Selection Items
N GMTSN,SELREF,GMREF I +X,(X["LAB(60,") D
. S SELREF=U_$P(X,";",2)_+X_",",GMREF=X
. I '$L($P($G(@(SELREF_"0)")),U,5)) D RESOLVE(GMREF)
I $S('$D(DA(1)):1,'$D(DA(2)):1,1:0) Q
S (GMTSNCNT,GMTSN)=0 F S GMTSN=$O(^GMT(142,DA(2),1,DA(1),1,GMTSN)) Q:'GMTSN S GMTSNCNT=GMTSNCNT+1
S $P(^GMT(142,DA(2),1,DA(1),1,0),U,4)=GMTSNCNT
I SELCNT,(GMTSNCNT'<SELCNT) W !?2,$C(7),"MAXIMUM # OF ITEMS SELECTED.",!
Q
RESOLVE(GMREF) ; Resolve Compound Items
N C,IEN,GMI,GMHEAD,P,X,Y K ^XUTL("OR",$J,"ORU"),^("ORV"),^("ORW")
S GMHEAD="-- "_$P($G(^LAB(60,+GMREF,.1)),U)_" --"
S ^XUTL("OR",$J,"GMTS",0)="LAB TEST^1^^0" D COMPILE(+GMREF)
S ORUS="^XUTL(""OR"","_$J_",""GMTS"",",ORUS("T")="D HEADER^GMTSRM3"
I +$G(SELCNT) D
. S ORUS(0)="40MN^"_SELCNT
. S ORUS("A")="Select 1 - "_SELCNT_" LAB TEST(s): ",ORUS("B")="1-"_SELCNT
E S ORUS(0)="40MN",ORUS("A")="Select LAB TEST(s): ",ORUS("B")="ALL"
D EN^ORUS K ^XUTL("OR",$J,"GMTS"),^("ORU"),^("ORV"),^("ORW")
I $S('$D(CMP(142.14,DA)):1,$G(CMP(142.14,DA))=GMREF:1,1:0) D
. I $D(CMP(142.14,+$O(CMP(142.14,DA)))) D
. . S GMI=DA F S GMI=$O(CMP(142.14,GMI)) Q:+GMI'>0!(GMI'<(DA+Y)) S CMP(142.14,GMI+Y)=CMP(142.14,GMI)
. S GMI=0 F S GMI=$O(Y(GMI)) Q:GMI'>0 D
. . I '$D(^GMT(142,+$G(DA(2)),1,+$G(DA(1)),1,"B",+$G(Y(GMI))_";LAB(60,")) D
. . . S CMP(142.14,((GMI-1)+DA))=+$G(Y(GMI))_";LAB(60,"
S IEN=0 F S IEN=$O(CMP(142.14,IEN)) Q:IEN'>0 D
. I $D(^GMT(142,+$G(DA(2)),1,+$G(DA(1)),1,"B",CMP(142.14,IEN))) W $C(7),!," Duplicate test omitted." K CMP(142.14,IEN) Q
. D LOADSEL^GMTSRM1A
I $P($G(^LAB(60,+$G(^GMT(142,+DA(2),1,+DA(1),1,+DA,0)),0)),U,5)']"" D
. N REC,SUBREC,SUBSUB S REC=DA(2),SUBREC=DA(1),SUBSUB=DA
. D DELCOSMO(REC,SUBREC,SUBSUB)
Q
REITEM(GMTST,GMTSS) ; Resequence Items
Q:+($G(GMTST))'>0 Q:'$D(^GMT(142,+($G(GMTST))))
Q:+($G(GMTSS))'>0 Q:'$D(^GMT(142,+GMTST,1,+($G(GMTSS))))
N DIR,DTOUT,DUOUT,DIRUT,DIROUT,GMTSA,GMTSCN,GMTSCA,GMTSMAX,GMTSN,GMTSI,Y,X
D ARY(GMTST,GMTSS,.GMTSA) Q:+($G(GMTSA(0)))'>1
S GMTSCN=$P($G(^GMT(142,GMTST,1,GMTSS,0)),"^",2),GMTSCA=$P($G(^GMT(142.1,+GMTSCN,0)),"^",4),GMTSCN=$P($G(^GMT(142.1,+GMTSCN,0)),"^",1)
W !,?1,GMTSCN," ",$S($L(GMTSCA):"(",1:""),GMTSCA,$S($L(GMTSCA):")",1:"")
S GMTSN=0 F S GMTSN=$O(GMTSA(GMTSN)) Q:+GMTSN=0 W !,$J(GMTSN,6)," ",GMTSA(GMTSN)
S DIR(0)="YAO",DIR("?")="^D RIH^GMTSRM3",DIR("A")=" Do you want to resequence the selection items? "
W ! D ^DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) Q
Q:+Y'>0
N DA S DA(2)=+($G(GMTST)),DA(1)=+($G(GMTSS)) D RSI^GMTSRS2
Q
RIH ; Resequence Items Help
W !,?4,"Enter either 'Y' or 'N'." Q
ARY(GMTST,GMTSS,ARY) ; Array of Items
N GMTSC,GMTSI,GMTSVAL,GMTSPTR,GMTSFRT,GMTSCRT,GMTSFFRT,GMTSFCRT,GMTSTYPE
N GMTSRT,GMTSUB S ARY(0)=0 Q:+($G(GMTST))'>0 Q:'$D(^GMT(142,+($G(GMTST)))) Q:+($G(GMTSS))'>0 Q:'$D(^GMT(142,+GMTST,1,+($G(GMTSS))))
S (GMTSC,GMTSI)=0 F S GMTSI=$O(^GMT(142,GMTST,1,GMTSS,1,GMTSI)) Q:+GMTSI=0 D
. S GMTSVAL=$G(^GMT(142,GMTST,1,GMTSS,1,GMTSI,0)),GMTSPTR=+GMTSVAL,GMTSFRT=$P(GMTSVAL,";",2) Q:GMTSFRT'["(" S:GMTSFRT'["^" GMTSFRT="^"_GMTSFRT
. S GMTSCRT=$$CREF^DILF(GMTSFRT),GMTSFFRT=GMTSFRT_GMTSPTR_","
. S GMTSFCRT=$$CREF^DILF(GMTSFFRT) Q:'$D(@GMTSFCRT) Q:'$L($G(@($P(GMTSFCRT,")",1)_",0)")))
. I GMTSFCRT["^AUTTHF(" D Q
..S GMTSTYPE=$S($P($G(@($P(GMTSFCRT,")",1)_",0)")),"^",10)="C":"CATEGORY",$P($G(@($P(GMTSFCRT,")",1)_",0)")),"^",10)="F":"FACTOR",1:" ")
..S GMTSUB=$$LJ^XLFSTR($P($G(@($P(GMTSFCRT,")",1)_",0)")),"^",1),42)_GMTSTYPE,GMTSC=GMTSC+1,ARY(GMTSC)=GMTSUB,ARY(0)=+GMTSC
. S GMTSUB=$P($G(@($P(GMTSFCRT,")",1)_",0)")),"^",1),GMTSC=GMTSC+1,ARY(GMTSC)=GMTSUB,ARY(0)=+GMTSC
Q
COMPILE(GMTEST) ; Compile Menu
N GMC,GMI,GMJ,GMROOT
S GMI=0 F S GMI=$O(^LAB(60,GMTEST,2,GMI)) Q:GMI'>0 D
. S GMJ=+$G(^LAB(60,GMTEST,2,+GMI,0))
. S GMROOT=$G(^LAB(60,+GMJ,0))
. I $L($P(GMROOT,U,5)) D
. . S GMC=+$P($G(^XUTL("OR",$J,"GMTS",0)),U,4)+1
. . S ^XUTL("OR",$J,"GMTS",GMJ,0)=$P(GMROOT,U),$P(^XUTL("OR",$J,"GMTS",0),U,4)=GMC
. E D COMPILE(+$G(^LAB(60,GMTEST,2,GMI,0)))
Q
W !!?15,"Select the tests which you wish to include, in the",!?19,"sequence in which you wish them to appear."
W !!?((80-$L(GMHEAD))\2),GMHEAD,!
Q
DELCOSMO(X1,X2,X3) ; Delete Cosmic Lab Tests from Selection Items
N TEST S TEST=$G(^GMT(142,X1,1,X2,1,X3,0))
K ^GMT(142,X1,1,X2,1,"B",TEST),^GMT(142,X1,1,X2,1,X3,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSRM3 5221 printed Oct 16, 2024@18:00:56 Page 2
GMTSRM3 ; SLC/DLT - Create/Modify - Selection Items ; 08/27/2002
+1 ;;2.7;Health Summary;**56,62,63**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 2160 ^XUTL("OR")
+5 ; DBIA 67 ^LAB(60,
+6 ; DBIA 3137 EN^ORUS
+7 ;
EN ; Entry Logic for Selection Items
+1 NEW GMTSN
WRITE !!,$SELECT($ORDER(^GMT(142,DA(1),1,DA,1,0)):"Current selection items are: ",1:"No selection items chosen.")
+2 SET GMTSN=0
FOR
SET GMTSN=$ORDER(^GMT(142,DA(1),1,DA,1,GMTSN))
if +GMTSN'>0
QUIT
SET GMTSN(0)=^(GMTSN,0)
DO SHOWSEL
+3 WRITE !!,"Select new items one at a time in the sequence you want them displayed."
+4 WRITE !,"You may select "
IF SELCNT=""
WRITE "any number of items.",!
+5 IF '$TEST
WRITE "up to ",SELCNT," items.",!
+6 QUIT
SHOWSEL ; Writes Current Selection Items
+1 WRITE ?30,$PIECE(@("^"_$PIECE(GMTSN(0),";",2)_+GMTSN(0)_",0)"),U),!
+2 QUIT
EXIT ; Exit Logic for Selection Items
+1 NEW GMTSN,SELREF,GMREF
IF +X
IF (X["LAB(60,")
Begin DoDot:1
+2 SET SELREF=U_$PIECE(X,";",2)_+X_","
SET GMREF=X
+3 IF '$LENGTH($PIECE($GET(@(SELREF_"0)")),U,5))
DO RESOLVE(GMREF)
End DoDot:1
+4 IF $SELECT('$DATA(DA(1)):1,'$DATA(DA(2)):1,1:0)
QUIT
+5 SET (GMTSNCNT,GMTSN)=0
FOR
SET GMTSN=$ORDER(^GMT(142,DA(2),1,DA(1),1,GMTSN))
if 'GMTSN
QUIT
SET GMTSNCNT=GMTSNCNT+1
+6 SET $PIECE(^GMT(142,DA(2),1,DA(1),1,0),U,4)=GMTSNCNT
+7 IF SELCNT
IF (GMTSNCNT'<SELCNT)
WRITE !?2,$CHAR(7),"MAXIMUM # OF ITEMS SELECTED.",!
+8 QUIT
RESOLVE(GMREF) ; Resolve Compound Items
+1 NEW C,IEN,GMI,GMHEAD,P,X,Y
KILL ^XUTL("OR",$JOB,"ORU"),^("ORV"),^("ORW")
+2 SET GMHEAD="-- "_$PIECE($GET(^LAB(60,+GMREF,.1)),U)_" --"
+3 SET ^XUTL("OR",$JOB,"GMTS",0)="LAB TEST^1^^0"
DO COMPILE(+GMREF)
+4 SET ORUS="^XUTL(""OR"","_$JOB_",""GMTS"","
SET ORUS("T")="D HEADER^GMTSRM3"
+5 IF +$GET(SELCNT)
Begin DoDot:1
+6 SET ORUS(0)="40MN^"_SELCNT
+7 SET ORUS("A")="Select 1 - "_SELCNT_" LAB TEST(s): "
SET ORUS("B")="1-"_SELCNT
End DoDot:1
+8 IF '$TEST
SET ORUS(0)="40MN"
SET ORUS("A")="Select LAB TEST(s): "
SET ORUS("B")="ALL"
+9 DO EN^ORUS
KILL ^XUTL("OR",$JOB,"GMTS"),^("ORU"),^("ORV"),^("ORW")
+10 IF $SELECT('$DATA(CMP(142.14,DA)):1,$GET(CMP(142.14,DA))=GMREF:1,1:0)
Begin DoDot:1
+11 IF $DATA(CMP(142.14,+$ORDER(CMP(142.14,DA))))
Begin DoDot:2
+12 SET GMI=DA
FOR
SET GMI=$ORDER(CMP(142.14,GMI))
if +GMI'>0!(GMI'<(DA+Y))
QUIT
SET CMP(142.14,GMI+Y)=CMP(142.14,GMI)
End DoDot:2
+13 SET GMI=0
FOR
SET GMI=$ORDER(Y(GMI))
if GMI'>0
QUIT
Begin DoDot:2
+14 IF '$DATA(^GMT(142,+$GET(DA(2)),1,+$GET(DA(1)),1,"B",+$GET(Y(GMI))_";LAB(60,"))
Begin DoDot:3
+15 SET CMP(142.14,((GMI-1)+DA))=+$GET(Y(GMI))_";LAB(60,"
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET IEN=0
FOR
SET IEN=$ORDER(CMP(142.14,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+17 IF $DATA(^GMT(142,+$GET(DA(2)),1,+$GET(DA(1)),1,"B",CMP(142.14,IEN)))
WRITE $CHAR(7),!," Duplicate test omitted."
KILL CMP(142.14,IEN)
QUIT
+18 DO LOADSEL^GMTSRM1A
End DoDot:1
+19 IF $PIECE($GET(^LAB(60,+$GET(^GMT(142,+DA(2),1,+DA(1),1,+DA,0)),0)),U,5)']""
Begin DoDot:1
+20 NEW REC,SUBREC,SUBSUB
SET REC=DA(2)
SET SUBREC=DA(1)
SET SUBSUB=DA
+21 DO DELCOSMO(REC,SUBREC,SUBSUB)
End DoDot:1
+22 QUIT
REITEM(GMTST,GMTSS) ; Resequence Items
+1 if +($GET(GMTST))'>0
QUIT
if '$DATA(^GMT(142,+($GET(GMTST))))
QUIT
+2 if +($GET(GMTSS))'>0
QUIT
if '$DATA(^GMT(142,+GMTST,1,+($GET(GMTSS))))
QUIT
+3 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,GMTSA,GMTSCN,GMTSCA,GMTSMAX,GMTSN,GMTSI,Y,X
+4 DO ARY(GMTST,GMTSS,.GMTSA)
if +($GET(GMTSA(0)))'>1
QUIT
+5 SET GMTSCN=$PIECE($GET(^GMT(142,GMTST,1,GMTSS,0)),"^",2)
SET GMTSCA=$PIECE($GET(^GMT(142.1,+GMTSCN,0)),"^",4)
SET GMTSCN=$PIECE($GET(^GMT(142.1,+GMTSCN,0)),"^",1)
+6 WRITE !,?1,GMTSCN," ",$SELECT($LENGTH(GMTSCA):"(",1:""),GMTSCA,$SELECT($LENGTH(GMTSCA):")",1:"")
+7 SET GMTSN=0
FOR
SET GMTSN=$ORDER(GMTSA(GMTSN))
if +GMTSN=0
QUIT
WRITE !,$JUSTIFY(GMTSN,6)," ",GMTSA(GMTSN)
+8 SET DIR(0)="YAO"
SET DIR("?")="^D RIH^GMTSRM3"
SET DIR("A")=" Do you want to resequence the selection items? "
+9 WRITE !
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
QUIT
+10 if +Y'>0
QUIT
+11 NEW DA
SET DA(2)=+($GET(GMTST))
SET DA(1)=+($GET(GMTSS))
DO RSI^GMTSRS2
+12 QUIT
RIH ; Resequence Items Help
+1 WRITE !,?4,"Enter either 'Y' or 'N'."
QUIT
ARY(GMTST,GMTSS,ARY) ; Array of Items
+1 NEW GMTSC,GMTSI,GMTSVAL,GMTSPTR,GMTSFRT,GMTSCRT,GMTSFFRT,GMTSFCRT,GMTSTYPE
+2 NEW GMTSRT,GMTSUB
SET ARY(0)=0
if +($GET(GMTST))'>0
QUIT
if '$DATA(^GMT(142,+($GET(GMTST))))
QUIT
if +($GET(GMTSS))'>0
QUIT
if '$DATA(^GMT(142,+GMTST,1,+($GET(GMTSS))))
QUIT
+3 SET (GMTSC,GMTSI)=0
FOR
SET GMTSI=$ORDER(^GMT(142,GMTST,1,GMTSS,1,GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+4 SET GMTSVAL=$GET(^GMT(142,GMTST,1,GMTSS,1,GMTSI,0))
SET GMTSPTR=+GMTSVAL
SET GMTSFRT=$PIECE(GMTSVAL,";",2)
if GMTSFRT'["("
QUIT
if GMTSFRT'["^"
SET GMTSFRT="^"_GMTSFRT
+5 SET GMTSCRT=$$CREF^DILF(GMTSFRT)
SET GMTSFFRT=GMTSFRT_GMTSPTR_","
+6 SET GMTSFCRT=$$CREF^DILF(GMTSFFRT)
if '$DATA(@GMTSFCRT)
QUIT
if '$LENGTH($GET(@($PIECE(GMTSFCRT,")",1)_",0)")))
QUIT
+7 IF GMTSFCRT["^AUTTHF("
Begin DoDot:2
+8 SET GMTSTYPE=$SELECT($PIECE($GET(@($PIECE(GMTSFCRT,")",1)_",0)")),"^",10)="C":"CATEGORY",$PIECE($GET(@($PIECE(GMTSFCRT,")",1)_",0)")),"^",10)="F":"FACTOR",1:" ")
+9 SET GMTSUB=$$LJ^XLFSTR($PIECE($GET(@($PIECE(GMTSFCRT,")",1)_",0)")),"^",1),42)_GMTSTYPE
SET GMTSC=GMTSC+1
SET ARY(GMTSC)=GMTSUB
SET ARY(0)=+GMTSC
End DoDot:2
QUIT
+10 SET GMTSUB=$PIECE($GET(@($PIECE(GMTSFCRT,")",1)_",0)")),"^",1)
SET GMTSC=GMTSC+1
SET ARY(GMTSC)=GMTSUB
SET ARY(0)=+GMTSC
End DoDot:1
+11 QUIT
COMPILE(GMTEST) ; Compile Menu
+1 NEW GMC,GMI,GMJ,GMROOT
+2 SET GMI=0
FOR
SET GMI=$ORDER(^LAB(60,GMTEST,2,GMI))
if GMI'>0
QUIT
Begin DoDot:1
+3 SET GMJ=+$GET(^LAB(60,GMTEST,2,+GMI,0))
+4 SET GMROOT=$GET(^LAB(60,+GMJ,0))
+5 IF $LENGTH($PIECE(GMROOT,U,5))
Begin DoDot:2
+6 SET GMC=+$PIECE($GET(^XUTL("OR",$JOB,"GMTS",0)),U,4)+1
+7 SET ^XUTL("OR",$JOB,"GMTS",GMJ,0)=$PIECE(GMROOT,U)
SET $PIECE(^XUTL("OR",$JOB,"GMTS",0),U,4)=GMC
End DoDot:2
+8 IF '$TEST
DO COMPILE(+$GET(^LAB(60,GMTEST,2,GMI,0)))
End DoDot:1
+9 QUIT
+1 WRITE !!?15,"Select the tests which you wish to include, in the",!?19,"sequence in which you wish them to appear."
+2 WRITE !!?((80-$LENGTH(GMHEAD))\2),GMHEAD,!
+3 QUIT
DELCOSMO(X1,X2,X3) ; Delete Cosmic Lab Tests from Selection Items
+1 NEW TEST
SET TEST=$GET(^GMT(142,X1,1,X2,1,X3,0))
+2 KILL ^GMT(142,X1,1,X2,1,"B",TEST),^GMT(142,X1,1,X2,1,X3,0)
+3 QUIT
