DICM1 ;SFISC/XAK,TKW - LOOKUP WHEN INPUT MUST BE TRANSFORMED ;01MAR2016
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
G @Y
;
P ;POINTERS
G P^DICM0
;
D ;DATES
S %=DS I %["t",$G(^DI(.81,+$P(DS,"t",2),201,2,31))["%DT" S %=^(31) ;MAY BE EXTENDED TYPE THAT IS DATE-VALUED (LIKE UTC), SO GET INPUT TRANSFORM
I $S(X'?.N:1,$L(X)>15:0,1:1) S %DT=$S($D(^DD(+DO(2),.001)):"N",1:"")_$P($P(%,"%DT=""",2),"""") F %="E","R" S %DT=$P(%DT,%)_$P(%DT,%,2)
I D ^%DT S X=Y K %DT I X>1 D Q
. I $D(DINDEX(1,"TRANCODE"))#2 D Q
. . X DINDEX(1,"TRANCODE") I $G(X)="" K X S Y=-1 Q
. . I ('$D(DINDEX(1,"TRANOUT"))#2)!(DIC(0)'["E")!($D(DDS)) Q
. . N % S %=X N X S X=% X DINDEX(1,"TRANOUT") W " ",X Q
. Q:DIC(0)'["E"
. I '$D(DDS) W " " D DT^DIQ
. S DIDA=1 Q
K X Q
;
S ;SETS
N A8,A9,DDH S DDH=0
I $P(DS,U,2)["*"!($D(DIC("S"))) D SC
S DICR(DICR,1)=1,I=$P(DS,U,3),DD=+$P($P(DS,U,2),"t",2) I I="",DD S I=$$PROP4TYP^DIETLIBF("SET OF CODES",DD)
S DD=$P(";"_I,";"_X_":",2) ;SEE IF 'X' IS AN INTERNAL CODE
N DS S DS=0
I DD]"" S Y=X X:$D(A9) A9 I D SDSP,SK Q
SS S DICMF=0
F DICM=1:1 S DD=$P(I,";",DICM) Q:DD="" I $P($P(DD,":",2),X)="" D ;SEE IF 'X' IS AN EXTERNAL CODE
. S Y=$P(DD,":"),DD=$P(DD,":",2) Q:DIC(0)["X"&(DD'=X)
. I $D(A9) X A9 E Q
. I DIC(0)["O"!(DIC(0)'["E") S:DD=X DICMF=1 I DD'=X,DICMF=1 Q
. S DS=DS+1 D SDSP
. S DS(DS)=Y_"^ "_DDH_" "_DDH(DDH,Y)
G:DDH=0 NO
I DDH=1 D G SK
. S X=$O(DDH(1,""))
. W:DIC(0)["E"&('$D(DDS)) " ("_DDH(1,X)_")"
. S:$D(DS(1,"T")) X=DS(1,"T") Q
G:DIC(0)'["E" NO
I $D(DDS) S DD=DDH,DDD=2 K DDQ D LIST^DDSU K DDD,DDQ G:$D(DTOUT) NO
I '$D(DDS) F D Q:DICM'="AGN"
. F DICM=1:1:DDH W !,$P(DS(DICM),U,2,999)
. W !,"CHOOSE 1-"_DDH_": "
. R DIY:$S($D(DTIME):DTIME,1:300) E Q
. Q:U[DIY!(DIY[U) I DIY?1.N,$D(DS(+DIY)) Q
. W $C(7),"??" S DICM="AGN"
G:+$P(DIY,"E")'=DIY NO G:'$D(DS(+DIY)) NO
S X=$P(DS(DIY),U)
I '$D(DDS) W " "_DDH(DIY,X),!
S:$D(DS(DIY,"T")) X=DS(DIY,"T")
G SK
;
NO K X,Y S Y=-1
SK K DIC("S") S:$D(A8) DIC("S")=A8
K DDH,DICM,DICMF,DICMS
Q
SC ;SCREENS ON SETS
S:$D(DIC("S")) A8=DIC("S") Q:$P(DS,U,2)'["*"
Q:'$D(^DD(+DO(2),.01,12.1)) X ^(12.1) Q:'$D(DIC("S"))
S Y="("_DIC,I="DIC"_DICR,%=""""_%_"""",A9="X DIC(""S"")"
Q:$G(DICR(DICR))?1"""".E1""""
;I DS["DINUM=X" S D=D_" E I $D"_Y_"Y,0))" Q
S A9=A9_" E F "_I_"=0:0 S "_I_"=$O"_Y
I @("$O"_Y_%_",0))'=""""") S A9=A9_%_",Y,"_I_")) Q:"_I_"="""" "_$S($D(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$D"_Y_I_",0)) Q" Q
S A9=A9_I_")) Q:'"_I_" "_$S($D(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$P(^("_I_",0),U)=Y Q" Q
;
SDSP ; Execute screen, transform, set up output for display
N DISAVX,DISAVY,DIXX,DIOUT S DIOUT=0,DIXX=Y
S DDH=DDH+1,DDH(DDH,Y)=$P(" (^",U,(DS=0))_Y
I $D(DINDEX(1,"TRANCODE"))#2 D S:'DIOUT&('DS) X=DIXX I DIOUT S Y=-1 Q
. S DISAVY=Y N X,Y S X=DISAVY
. X DINDEX(1,"TRANCODE") I $G(X)="" S DIOUT=1 Q
. S DIXX=X I DS S DS(DS,"T")=X Q
I $G(DINDEX(1,"TRANOUT"))]"" D
. S DISAVY=Y N X,Y S X=DIXX X DINDEX(1,"TRANOUT")
. S DDH(DDH,DISAVY)=$P(" (^",U,(DS=0))_$G(X) Q
S DDH(DDH,Y)=DDH(DDH,Y)_" "_$P(DD,";")_$P(")^",U,(DS=0))
I DS=0,DIC(0)["E",'$D(DDS) W DDH(DDH,Y)
Q
;
V ;VARIABLE POINTER
I X["?BAD" K X Q
D ^DICM2,DO^DIC1
Q
;
T ; Execute TRANSFORM code for indexes other than Pointers, Date, VP or Sets.
N DIXX S DIXX=X
X DINDEX(1,"TRANCODE") I $G(X)="" K X S Y=-1 Q
I DIXX=X K X S Y=-1
Q
;
SOU ;
S DSOU="01230129022455012623019202",DSOV=X,X=$C($A(X)-(X?1L.E*32)),DIX=$E(DSOU,$A(X)-64) F DIY=2:1 S Y=$E(DSOV,DIY) Q:","[Y I Y?1A S %=$E(DSOU,$A(Y)-$S(Y?1U:64,1:96)) I %-DIX,%-9 S DIX=% I % S X=X_% Q:$L(X)=4
S X=$E(X_"000",1,4) K DSOU,DSOV Q
;
ACT ;
S DIY=Y,DIY(1)=DIC,DIC("W")="",DIX=X
A I $G(DO(2)) X:$D(^DD(+DO(2),0,"ACT")) ^("ACT")
I Y<0 S DIC=DIY(1),X=DIX G W
I $G(DO(2))["P" N % S %=^DD(+DO(2),.01,0) I $P(%,U,2)["P",$P(%,U,3)]"" S DIC=U_$P(%,U,3) D DO I $D(@(DIC_+$P(Y,U,2)_",0)")) S Y=+$P(Y,U,2)_U_$P(^(0),U) G A
S Y=DIY,DIC=DIY(1),X=DIX
W K DIC("W")
DO K DO D DO^DIC1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICM1 4330 printed Sep 23, 2025@20:22:25 Page 2
DICM1 ;SFISC/XAK,TKW - LOOKUP WHEN INPUT MUST BE TRANSFORMED ;01MAR2016
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 GOTO @Y
+8 ;
P ;POINTERS
+1 GOTO P^DICM0
+2 ;
D ;DATES
+1 ;MAY BE EXTENDED TYPE THAT IS DATE-VALUED (LIKE UTC), SO GET INPUT TRANSFORM
SET %=DS
IF %["t"
IF $GET(^DI(.81,+$PIECE(DS,"t",2),201,2,31))["%DT"
SET %=^(31)
+2 IF $SELECT(X'?.N:1,$LENGTH(X)>15:0,1:1)
SET %DT=$SELECT($DATA(^DD(+DO(2),.001)):"N",1:"")_$PIECE($PIECE(%,"%DT=""",2),"""")
FOR %="E","R"
SET %DT=$PIECE(%DT,%)_$PIECE(%DT,%,2)
+3 IF $TEST
DO ^%DT
SET X=Y
KILL %DT
IF X>1
Begin DoDot:1
+4 IF $DATA(DINDEX(1,"TRANCODE"))#2
Begin DoDot:2
+5 XECUTE DINDEX(1,"TRANCODE")
IF $GET(X)=""
KILL X
SET Y=-1
QUIT
+6 IF ('$DATA(DINDEX(1,"TRANOUT"))#2)!(DIC(0)'["E")!($DATA(DDS))
QUIT
+7 NEW %
SET %=X
NEW X
SET X=%
XECUTE DINDEX(1,"TRANOUT")
WRITE " ",X
QUIT
End DoDot:2
QUIT
+8 if DIC(0)'["E"
QUIT
+9 IF '$DATA(DDS)
WRITE " "
DO DT^DIQ
+10 SET DIDA=1
QUIT
End DoDot:1
QUIT
+11 KILL X
QUIT
+12 ;
S ;SETS
+1 NEW A8,A9,DDH
SET DDH=0
+2 IF $PIECE(DS,U,2)["*"!($DATA(DIC("S")))
DO SC
+3 SET DICR(DICR,1)=1
SET I=$PIECE(DS,U,3)
SET DD=+$PIECE($PIECE(DS,U,2),"t",2)
IF I=""
IF DD
SET I=$$PROP4TYP^DIETLIBF("SET OF CODES",DD)
+4 ;SEE IF 'X' IS AN INTERNAL CODE
SET DD=$PIECE(";"_I,";"_X_":",2)
+5 NEW DS
SET DS=0
+6 IF DD]""
SET Y=X
if $DATA(A9)
XECUTE A9
IF $TEST
DO SDSP
DO SK
QUIT
SS SET DICMF=0
+1 ;SEE IF 'X' IS AN EXTERNAL CODE
FOR DICM=1:1
SET DD=$PIECE(I,";",DICM)
if DD=""
QUIT
IF $PIECE($PIECE(DD,":",2),X)=""
Begin DoDot:1
+2 SET Y=$PIECE(DD,":")
SET DD=$PIECE(DD,":",2)
if DIC(0)["X"&(DD'=X)
QUIT
+3 IF $DATA(A9)
XECUTE A9
IF '$TEST
QUIT
+4 IF DIC(0)["O"!(DIC(0)'["E")
if DD=X
SET DICMF=1
IF DD'=X
IF DICMF=1
QUIT
+5 SET DS=DS+1
DO SDSP
+6 SET DS(DS)=Y_"^ "_DDH_" "_DDH(DDH,Y)
End DoDot:1
+7 if DDH=0
GOTO NO
+8 IF DDH=1
Begin DoDot:1
+9 SET X=$ORDER(DDH(1,""))
+10 if DIC(0)["E"&('$DATA(DDS))
WRITE " ("_DDH(1,X)_")"
+11 if $DATA(DS(1,"T"))
SET X=DS(1,"T")
QUIT
End DoDot:1
GOTO SK
+12 if DIC(0)'["E"
GOTO NO
+13 IF $DATA(DDS)
SET DD=DDH
SET DDD=2
KILL DDQ
DO LIST^DDSU
KILL DDD,DDQ
if $DATA(DTOUT)
GOTO NO
+14 IF '$DATA(DDS)
FOR
Begin DoDot:1
+15 FOR DICM=1:1:DDH
WRITE !,$PIECE(DS(DICM),U,2,999)
+16 WRITE !,"CHOOSE 1-"_DDH_": "
+17 READ DIY:$SELECT($DATA(DTIME):DTIME,1:300)
IF '$TEST
QUIT
+18 if U[DIY!(DIY[U)
QUIT
IF DIY?1.N
IF $DATA(DS(+DIY))
QUIT
+19 WRITE $CHAR(7),"??"
SET DICM="AGN"
End DoDot:1
if DICM'="AGN"
QUIT
+20 if +$PIECE(DIY,"E")'=DIY
GOTO NO
if '$DATA(DS(+DIY))
GOTO NO
+21 SET X=$PIECE(DS(DIY),U)
+22 IF '$DATA(DDS)
WRITE " "_DDH(DIY,X),!
+23 if $DATA(DS(DIY,"T"))
SET X=DS(DIY,"T")
+24 GOTO SK
+25 ;
NO KILL X,Y
SET Y=-1
SK KILL DIC("S")
if $DATA(A8)
SET DIC("S")=A8
+1 KILL DDH,DICM,DICMF,DICMS
+2 QUIT
SC ;SCREENS ON SETS
+1 if $DATA(DIC("S"))
SET A8=DIC("S")
if $PIECE(DS,U,2)'["*"
QUIT
+2 if '$DATA(^DD(+DO(2),.01,12.1))
QUIT
XECUTE ^(12.1)
if '$DATA(DIC("S"))
QUIT
+3 SET Y="("_DIC
SET I="DIC"_DICR
SET %=""""_%_""""
SET A9="X DIC(""S"")"
+4 if $GET(DICR(DICR))?1"""".E1""""
QUIT
+5 ;I DS["DINUM=X" S D=D_" E I $D"_Y_"Y,0))" Q
+6 SET A9=A9_" E F "_I_"=0:0 S "_I_"=$O"_Y
+7 IF @("$O"_Y_%_",0))'=""""")
SET A9=A9_%_",Y,"_I_")) Q:"_I_"="""" "_$SELECT($DATA(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$D"_Y_I_",0)) Q"
QUIT
+8 SET A9=A9_I_")) Q:'"_I_" "_$SELECT($DATA(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$P(^("_I_",0),U)=Y Q"
QUIT
+9 ;
SDSP ; Execute screen, transform, set up output for display
+1 NEW DISAVX,DISAVY,DIXX,DIOUT
SET DIOUT=0
SET DIXX=Y
+2 SET DDH=DDH+1
SET DDH(DDH,Y)=$PIECE(" (^",U,(DS=0))_Y
+3 IF $DATA(DINDEX(1,"TRANCODE"))#2
Begin DoDot:1
+4 SET DISAVY=Y
NEW X,Y
SET X=DISAVY
+5 XECUTE DINDEX(1,"TRANCODE")
IF $GET(X)=""
SET DIOUT=1
QUIT
+6 SET DIXX=X
IF DS
SET DS(DS,"T")=X
QUIT
End DoDot:1
if 'DIOUT&('DS)
SET X=DIXX
IF DIOUT
SET Y=-1
QUIT
+7 IF $GET(DINDEX(1,"TRANOUT"))]""
Begin DoDot:1
+8 SET DISAVY=Y
NEW X,Y
SET X=DIXX
XECUTE DINDEX(1,"TRANOUT")
+9 SET DDH(DDH,DISAVY)=$PIECE(" (^",U,(DS=0))_$GET(X)
QUIT
End DoDot:1
+10 SET DDH(DDH,Y)=DDH(DDH,Y)_" "_$PIECE(DD,";")_$PIECE(")^",U,(DS=0))
+11 IF DS=0
IF DIC(0)["E"
IF '$DATA(DDS)
WRITE DDH(DDH,Y)
+12 QUIT
+13 ;
V ;VARIABLE POINTER
+1 IF X["?BAD"
KILL X
QUIT
+2 DO ^DICM2
DO DO^DIC1
+3 QUIT
+4 ;
T ; Execute TRANSFORM code for indexes other than Pointers, Date, VP or Sets.
+1 NEW DIXX
SET DIXX=X
+2 XECUTE DINDEX(1,"TRANCODE")
IF $GET(X)=""
KILL X
SET Y=-1
QUIT
+3 IF DIXX=X
KILL X
SET Y=-1
+4 QUIT
+5 ;
SOU ;
+1 SET DSOU="01230129022455012623019202"
SET DSOV=X
SET X=$CHAR($ASCII(X)-(X?1L.E*32))
SET DIX=$EXTRACT(DSOU,$ASCII(X)-64)
FOR DIY=2:1
SET Y=$EXTRACT(DSOV,DIY)
if ","[Y
QUIT
IF Y?1A
SET %=$EXTRACT(DSOU,$ASCII(Y)-$SELECT(Y?1U:64,1:96))
IF %-DIX
IF %-9
SET DIX=%
IF %
SET X=X_%
if $LENGTH(X)=4
QUIT
+2 SET X=$EXTRACT(X_"000",1,4)
KILL DSOU,DSOV
QUIT
+3 ;
ACT ;
+1 SET DIY=Y
SET DIY(1)=DIC
SET DIC("W")=""
SET DIX=X
A IF $GET(DO(2))
if $DATA(^DD(+DO(2),0,"ACT"))
XECUTE ^("ACT")
+1 IF Y<0
SET DIC=DIY(1)
SET X=DIX
GOTO W
+2 IF $GET(DO(2))["P"
NEW %
SET %=^DD(+DO(2),.01,0)
IF $PIECE(%,U,2)["P"
IF $PIECE(%,U,3)]""
SET DIC=U_$PIECE(%,U,3)
DO DO
IF $DATA(@(DIC_+$PIECE(Y,U,2)_",0)"))
SET Y=+$PIECE(Y,U,2)_U_$PIECE(^(0),U)
GOTO A
+3 SET Y=DIY
SET DIC=DIY(1)
SET X=DIX
W KILL DIC("W")
DO KILL DO
DO DO^DIC1
+1 QUIT
