- DICM1 ;SFISC/XAK,TKW-LOOKUP WHEN INPUT MUST BE TRANSFORMED ;2/8/00 09:29 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**20,29**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- G @Y
- ;
- P ;POINTERS
- G P^DICM0
- ;
- D ;DATES
- I $S(X'?.N:1,$L(X)>15:0,1:X>49) S %DT=$S($D(^DD(+DO(2),.001)):"N",1:"")_$P($P(DS,"%DT=""",2),"""") F %="E","R" D DZ
- 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
- DZ S %DT=$P(%DT,%)_$P(%DT,%,2) 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(";"_I,";"_X_":",2)
- 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
- . 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 X:$D(^DD(+DO(2),0,"ACT")) ^("ACT") I Y<0 S DIC=DIY(1),X=DIX K DIC("W"),DO Q
- I DO(2)["P" N % S %=^DD(+DO(2),.01,0) I $P(%,U,2)["P",$P(%,U,3)]"" S DIC=U_$P(%,U,3) K DO D DO^DIC1 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 K DIC("W"),DO D DO^DIC1 Q
- DICM1 ;SFISC/XAK,TKW-LOOKUP WHEN INPUT MUST BE TRANSFORMED ;2/8/00 09:29 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**20,29**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +4 GOTO @Y
- +5 ;
- P ;POINTERS
- +1 GOTO P^DICM0
- +2 ;
- D ;DATES
- +1 IF $SELECT(X'?.N:1,$LENGTH(X)>15:0,1:X>49)
- SET %DT=$SELECT($DATA(^DD(+DO(2),.001)):"N",1:"")_$PIECE($PIECE(DS,"%DT=""",2),"""")
- FOR %="E","R"
- DO DZ
- +2 IF $TEST
- DO ^%DT
- SET X=Y
- KILL %DT
- IF X>1
- Begin DoDot:1
- +3 IF $DATA(DINDEX(1,"TRANCODE"))#2
- Begin DoDot:2
- +4 XECUTE DINDEX(1,"TRANCODE")
- IF $GET(X)=""
- KILL X
- SET Y=-1
- QUIT
- +5 IF ('$DATA(DINDEX(1,"TRANOUT"))#2)!(DIC(0)'["E")!($DATA(DDS))
- QUIT
- +6 NEW %
- SET %=X
- NEW X
- SET X=%
- XECUTE DINDEX(1,"TRANOUT")
- WRITE " ",X
- QUIT
- End DoDot:2
- QUIT
- +7 IF DIC(0)'["E"
- QUIT
- +8 IF '$DATA(DDS)
- WRITE " "
- DO DT^DIQ
- +9 SET DIDA=1
- QUIT
- End DoDot:1
- QUIT
- +10 KILL X
- QUIT
- DZ SET %DT=$PIECE(%DT,%)_$PIECE(%DT,%,2)
- QUIT
- +1 ;
- 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(";"_I,";"_X_":",2)
- +4 NEW DS
- SET DS=0
- +5 IF DD]""
- SET Y=X
- IF $DATA(A9)
- XECUTE A9
- IF $TEST
- DO SDSP
- DO SK
- QUIT
- SS SET DICMF=0
- +1 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 $DATA(^DD(+DO(2),0,"ACT"))
- XECUTE ^("ACT")
- IF Y<0
- SET DIC=DIY(1)
- SET X=DIX
- KILL DIC("W"),DO
- QUIT
- +1 IF 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)
- KILL DO
- DO DO^DIC1
- IF $DATA(@(DIC_+$PIECE(Y,U,2)_",0)"))
- SET Y=+$PIECE(Y,U,2)_U_$PIECE(^(0),U)
- GOTO A
- +2 SET Y=DIY
- SET DIC=DIY(1)
- SET X=DIX
- KILL DIC("W"),DO
- DO DO^DIC1
- QUIT
