- DIP0 ;SFISC/XAK-COMPUTED FIELD ON A SORT, EDITING A SORT TEMPLATE ;02:12 PM 10 Nov 1999 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**2**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- S P=P_Q,DPP=$P(X,U,1)
- C ;
- S DICOMP=N_$E("?",''L),DM=X,DQI="Y(",DA="DPP("_DJ_",""OVF"_N_""",",DICMX="D M" G COLON:X?.E1":" D EN^DICOMP K DUOUT G X:'$D(X),X:Y["m" ;I Y["m" S X=DM_":" G C
- D XA,BB^DIP:Y["B" S:Y["D" R=R_"^^D" S Y=U_DPP,DPP(DJ,"CM")=X_" I D"_(N#100)_">0 S DISX("_DJ_")=X" G S^DIP
- ;
- XA F %=0:0 S %=$O(X(%)) Q:%="" S @(DA_"%)=X(%)")
- Q
- ;
- ;
- COLON D ^DICOMPW K DUOUT
- I $D(X),$S($D(DIL(+DP)):DIL(+DP)=DL,1:1) S DPP(DJ,DL,+Y)=DP_U_(Y["m")_U_X,DIL(+DP)=DL,N=+Y,DL=+DP,DV=$J("",DJ*2-2)_$O(^DD(DL,0,"NM",0))_" FIELD" S:$D(DIPP(DIJ,+DP))#2 $P(DIPP(DIJ),U,3)=DIPP(DIJ,+DP) D XA,L G Y^DIP
- X I $D(BY)#2,BY]"" S X=DM_C_BY,BY="" G C
- G B^DIP
- ;
- EDT ;
- S DIE="^DIBT(",DR=".01;3;6",DA=X,DIPP=DI,DIOVRD=1 D ^DIE S DI=DIPP,DE=$S(L=0!L:"SORT",1:L) K DR,DIE,DIPP,DIOVRD I '$D(DA)!($D(Y)) S (X,DJ)=+$G(DPP(0)) Q
- S %=$G(DPP(0,"IX")) I $P(%,U,2)]"",$P(%,U,4) D I $G(DPP(0))']"" S (X,DJ)=0 Q
- . N X,I,Y,F,T,O,Q,DIEDITBY S DIEDITBY=1 K FR(0),TO(0),DISPAR(0),DIPP
- . S BY(0)="^"_$P(%,U,2),L(0)=$P(%,U,4)
- . F I=L(0):1 Q:'$D(DPP(I)) M DIPP(I)=DPP(I) K DPP(I)
- . F I=1:1:(L(0)-1) D Q:'$G(L(0))
- .. S F=$P($G(DPP(I,"F")),U,2),T=$P($G(DPP(I,"T")),U,2) S:F]"" FR(0,I)=F S:T]"" TO(0,I)=T
- .. S O=$P($G(DPP(I)),U,4),Q="" S:O["!" Q=Q_"!" S:O["#" Q=Q_"#" S:$P($G(DPP(I)),U,5)]"" Q=Q_"^"_$P(DPP(I),U,5) S:Q]"" DISPAR(0,I)=Q
- .. I $G(DISPAR(0,I))]"",$G(DPP(I,"OUT"))]"" S DISPAR(0,I,"OUT")=DPP(I,"OUT")
- .. K DPP(I) Q
- . D BYOK^DIP100
- . I $G(DPP(0))]"" S X=DPP(0) F I=0:0 S I=$O(DIPP(I)) Q:'I S X=X+1 M DPP(X)=DIPP(I)
- . K DIPP Q
- S DIPP="",DIJ=0 F DJ=$G(DPP(0)):0 S DJ=$O(DPP(DJ)) Q:'DJ S DIJ=DIJ+1,%X="DPP(DJ,",%Y="DIPP(DIJ," D %XY^%RCR
- S DIJ=0 F DJ=$G(DPP(0)):0 S DJ=$O(DPP(DJ)) Q:DJ="" D
- . S DIJ=DIJ+1 N X S X=$P(DPP(DJ),U,4),X=$TR(X,"B",""),X=$S(X[Q:$P(X,Q,($L(X,Q)-1)),1:X)
- . S $P(DIPP(DIJ),U,3)=X_$P(DPP(DJ),U,3)_$P(DPP(DJ),U,5)
- . S %=+DPP(DJ) D E1 S %X=0 D E2 K DPP(DJ)
- . Q
- S DJ=$G(DPP(0)),DIJ=0 F S DIJ=+$O(DIPP(DIJ)) Q:'DIJ S DJ=DJ+1 D DJ^DIP Q:$D(DTOUT)!($D(DIRUT))!('$D(DJ)) W:X="@" " Deleted."
- K DIPP,DIJJ S:X'=U X=1 S:'$D(DXS) DXS=1 S DIEDT=1 Q
- E1 ;
- F DIJJ=0:1 Q:'$D(^DD(%,0,"UP")) S DIPP(DIJ,%)=$P(DIPP(DIJ),U,3),%=+^("UP"),$P(DIPP(DIJ),U,3)=$O(^("NM",0)),$P(DIPP(DIJ),U,1)=%
- Q
- E2 S %X=$O(DPP(DJ,%X)) I %X'>0 K %X Q
- G E2:'$D(DPP(DJ,%X,100)) S %=%X D E1 S %=DPP(DJ,%X,100)
- I $P(%,U,3) S DIPP(DIJ,+%)=$P(DIPP(DIJ),U,3),$P(DIPP(DIJ),U,3)=$P(^DIC(+%,0),U)_":",$P(DIPP(DIJ),U)=+% G E2
- I %'["Y(1)" S %=$F(%,"OVF0") Q:'% S %=+$E(DPP(DJ,%X,100),%+2,99),%=$P(DPP(DJ,%X,100),U)_U_DPP(DJ,"OVF0",%) Q:%'["Y(1)"
- WHO S G=$TR($P($P($P(%,"Y(1)",2),")):^(",2),")"),""""),P=$P(%,"Y(1)",3),P=$P($P(P,"U,",2),")") I G]"",P]"" S P=+$O(^DD(%X,"GL",G,P,0))
- I P,$D(^DD(%X,P,0)) S:DIJJ DIPP(DIJ,+%)=DIPP(DIJ,%X),DIPP(DIJ,%X)=$P(^(0),U)_":" S:'DIJJ DIPP(DIJ,+%)=$P(DIPP(DIJ),U,3),$P(DIPP(DIJ),U,3)=$P(^(0),U)_":"
- G E2
- ;
- L I $D(BY)#2 K DIC S DIC="^DD(DL,",DIC(0)="Z",X=$P(BY,C,1),BY=$P(BY,C,2,99) I X'="@" K DV Q
- K DIR D
- . N X S DIR(0)="FOU",DIR("A")=DV
- . S X=$P($G(DIPP(DIJ)),U,3) I X]"" S DIR("B")=X
- . I X="" S X=$G(DV(1)) I X]"" S DIR(0)="FOAU",DIR("A")=DV_": "_X_"// "
- . S DIR(0)=DIR(0)_"^1:255",DIR("?")="^D DIC^DIP0"
- D ^DIR K DIR,DV,DIRUT,DIROUT S:$D(DTOUT) X="^"
- K:X?1"^"1.E DUOUT
- I X="@" K DPP(DJ) S DJ=DJ-1
- D SETDIC Q
- ;
- SETDIC K DIC S DIC="^DD(DL,"
- S DIC("S")="S %=$P(^(0),U,2) I %'[""m"",$S('%:1,1:$P(^DD(+%,.01,0),U,2)'[""W""&$S($D(DIL(+%)):DIL(+%)=DL,1:1))"_$S($D(DICS):" "_DICS,1:""),DIC("W")="W:$P(^(0),U,2) "" (multiple)""",DIC(0)="ZE"_$E("O",$D(DIPP)#10) Q
- ;
- DIC D SETDIC,^DIC,DIP^DIQQ Q
- DIP0 ;SFISC/XAK-COMPUTED FIELD ON A SORT, EDITING A SORT TEMPLATE ;02:12 PM 10 Nov 1999 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**2**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +4 SET P=P_Q
- SET DPP=$PIECE(X,U,1)
- C ;
- +1 ;I Y["m" S X=DM_":" G C
- SET DICOMP=N_$EXTRACT("?",''L)
- SET DM=X
- SET DQI="Y("
- SET DA="DPP("_DJ_",""OVF"_N_""","
- SET DICMX="D M"
- IF X?.E1":"
- GOTO COLON
- DO EN^DICOMP
- KILL DUOUT
- IF '$DATA(X)
- GOTO X
- IF Y["m"
- GOTO X
- +2 DO XA
- IF Y["B"
- DO BB^DIP
- IF Y["D"
- SET R=R_"^^D"
- SET Y=U_DPP
- SET DPP(DJ,"CM")=X_" I D"_(N#100)_">0 S DISX("_DJ_")=X"
- GOTO S^DIP
- +3 ;
- XA FOR %=0:0
- SET %=$ORDER(X(%))
- IF %=""
- QUIT
- SET @(DA_"%)=X(%)")
- +1 QUIT
- +2 ;
- +3 ;
- COLON DO ^DICOMPW
- KILL DUOUT
- +1 IF $DATA(X)
- IF $SELECT($DATA(DIL(+DP)):DIL(+DP)=DL,1:1)
- SET DPP(DJ,DL,+Y)=DP_U_(Y["m")_U_X
- SET DIL(+DP)=DL
- SET N=+Y
- SET DL=+DP
- SET DV=$JUSTIFY("",DJ*2-2)_$ORDER(^DD(DL,0,"NM",0))_" FIELD"
- IF $DATA(DIPP(DIJ,+DP))#2
- SET $PIECE(DIPP(DIJ),U,3)=DIPP(DIJ,+DP)
- DO XA
- DO L
- GOTO Y^DIP
- X IF $DATA(BY)#2
- IF BY]""
- SET X=DM_C_BY
- SET BY=""
- GOTO C
- +1 GOTO B^DIP
- +2 ;
- EDT ;
- +1 SET DIE="^DIBT("
- SET DR=".01;3;6"
- SET DA=X
- SET DIPP=DI
- SET DIOVRD=1
- DO ^DIE
- SET DI=DIPP
- SET DE=$SELECT(L=0!L:"SORT",1:L)
- KILL DR,DIE,DIPP,DIOVRD
- IF '$DATA(DA)!($DATA(Y))
- SET (X,DJ)=+$GET(DPP(0))
- QUIT
- +2 SET %=$GET(DPP(0,"IX"))
- IF $PIECE(%,U,2)]""
- IF $PIECE(%,U,4)
- Begin DoDot:1
- +3 NEW X,I,Y,F,T,O,Q,DIEDITBY
- SET DIEDITBY=1
- KILL FR(0),TO(0),DISPAR(0),DIPP
- +4 SET BY(0)="^"_$PIECE(%,U,2)
- SET L(0)=$PIECE(%,U,4)
- +5 FOR I=L(0):1
- IF '$DATA(DPP(I))
- QUIT
- MERGE DIPP(I)=DPP(I)
- KILL DPP(I)
- +6 FOR I=1:1:(L(0)-1)
- Begin DoDot:2
- +7 SET F=$PIECE($GET(DPP(I,"F")),U,2)
- SET T=$PIECE($GET(DPP(I,"T")),U,2)
- IF F]""
- SET FR(0,I)=F
- IF T]""
- SET TO(0,I)=T
- +8 SET O=$PIECE($GET(DPP(I)),U,4)
- SET Q=""
- IF O["!"
- SET Q=Q_"!"
- IF O["#"
- SET Q=Q_"#"
- IF $PIECE($GET(DPP(I)),U,5)]""
- SET Q=Q_"^"_$PIECE(DPP(I),U,5)
- IF Q]""
- SET DISPAR(0,I)=Q
- +9 IF $GET(DISPAR(0,I))]""
- IF $GET(DPP(I,"OUT"))]""
- SET DISPAR(0,I,"OUT")=DPP(I,"OUT")
- +10 KILL DPP(I)
- QUIT
- End DoDot:2
- IF '$GET(L(0))
- QUIT
- +11 DO BYOK^DIP100
- +12 IF $GET(DPP(0))]""
- SET X=DPP(0)
- FOR I=0:0
- SET I=$ORDER(DIPP(I))
- IF 'I
- QUIT
- SET X=X+1
- MERGE DPP(X)=DIPP(I)
- +13 KILL DIPP
- QUIT
- End DoDot:1
- IF $GET(DPP(0))']""
- SET (X,DJ)=0
- QUIT
- +14 SET DIPP=""
- SET DIJ=0
- FOR DJ=$GET(DPP(0)):0
- SET DJ=$ORDER(DPP(DJ))
- IF 'DJ
- QUIT
- SET DIJ=DIJ+1
- SET %X="DPP(DJ,"
- SET %Y="DIPP(DIJ,"
- DO %XY^%RCR
- +15 SET DIJ=0
- FOR DJ=$GET(DPP(0)):0
- SET DJ=$ORDER(DPP(DJ))
- IF DJ=""
- QUIT
- Begin DoDot:1
- +16 SET DIJ=DIJ+1
- NEW X
- SET X=$PIECE(DPP(DJ),U,4)
- SET X=$TRANSLATE(X,"B","")
- SET X=$SELECT(X[Q:$PIECE(X,Q,($LENGTH(X,Q)-1)),1:X)
- +17 SET $PIECE(DIPP(DIJ),U,3)=X_$PIECE(DPP(DJ),U,3)_$PIECE(DPP(DJ),U,5)
- +18 SET %=+DPP(DJ)
- DO E1
- SET %X=0
- DO E2
- KILL DPP(DJ)
- +19 QUIT
- End DoDot:1
- +20 SET DJ=$GET(DPP(0))
- SET DIJ=0
- FOR
- SET DIJ=+$ORDER(DIPP(DIJ))
- IF 'DIJ
- QUIT
- SET DJ=DJ+1
- DO DJ^DIP
- IF $DATA(DTOUT)!($DATA(DIRUT))!('$DATA(DJ))
- QUIT
- IF X="@"
- WRITE " Deleted."
- +21 KILL DIPP,DIJJ
- IF X'=U
- SET X=1
- IF '$DATA(DXS)
- SET DXS=1
- SET DIEDT=1
- QUIT
- E1 ;
- +1 FOR DIJJ=0:1
- IF '$DATA(^DD(%,0,"UP"))
- QUIT
- SET DIPP(DIJ,%)=$PIECE(DIPP(DIJ),U,3)
- SET %=+^("UP")
- SET $PIECE(DIPP(DIJ),U,3)=$ORDER(^("NM",0))
- SET $PIECE(DIPP(DIJ),U,1)=%
- +2 QUIT
- E2 SET %X=$ORDER(DPP(DJ,%X))
- IF %X'>0
- KILL %X
- QUIT
- +1 IF '$DATA(DPP(DJ,%X,100))
- GOTO E2
- SET %=%X
- DO E1
- SET %=DPP(DJ,%X,100)
- +2 IF $PIECE(%,U,3)
- SET DIPP(DIJ,+%)=$PIECE(DIPP(DIJ),U,3)
- SET $PIECE(DIPP(DIJ),U,3)=$PIECE(^DIC(+%,0),U)_":"
- SET $PIECE(DIPP(DIJ),U)=+%
- GOTO E2
- +3 IF %'["Y(1)"
- SET %=$FIND(%,"OVF0")
- IF '%
- QUIT
- SET %=+$EXTRACT(DPP(DJ,%X,100),%+2,99)
- SET %=$PIECE(DPP(DJ,%X,100),U)_U_DPP(DJ,"OVF0",%)
- IF %'["Y(1)"
- QUIT
- WHO SET G=$TRANSLATE($PIECE($PIECE($PIECE(%,"Y(1)",2),")):^(",2),")"),"""")
- SET P=$PIECE(%,"Y(1)",3)
- SET P=$PIECE($PIECE(P,"U,",2),")")
- IF G]""
- IF P]""
- SET P=+$ORDER(^DD(%X,"GL",G,P,0))
- +1 IF P
- IF $DATA(^DD(%X,P,0))
- IF DIJJ
- SET DIPP(DIJ,+%)=DIPP(DIJ,%X)
- SET DIPP(DIJ,%X)=$PIECE(^(0),U)_":"
- IF 'DIJJ
- SET DIPP(DIJ,+%)=$PIECE(DIPP(DIJ),U,3)
- SET $PIECE(DIPP(DIJ),U,3)=$PIECE(^(0),U)_":"
- +2 GOTO E2
- +3 ;
- L IF $DATA(BY)#2
- KILL DIC
- SET DIC="^DD(DL,"
- SET DIC(0)="Z"
- SET X=$PIECE(BY,C,1)
- SET BY=$PIECE(BY,C,2,99)
- IF X'="@"
- KILL DV
- QUIT
- +1 KILL DIR
- Begin DoDot:1
- +2 NEW X
- SET DIR(0)="FOU"
- SET DIR("A")=DV
- +3 SET X=$PIECE($GET(DIPP(DIJ)),U,3)
- IF X]""
- SET DIR("B")=X
- +4 IF X=""
- SET X=$GET(DV(1))
- IF X]""
- SET DIR(0)="FOAU"
- SET DIR("A")=DV_": "_X_"// "
- +5 SET DIR(0)=DIR(0)_"^1:255"
- SET DIR("?")="^D DIC^DIP0"
- End DoDot:1
- +6 DO ^DIR
- KILL DIR,DV,DIRUT,DIROUT
- IF $DATA(DTOUT)
- SET X="^"
- +7 IF X?1"^"1.E
- KILL DUOUT
- +8 IF X="@"
- KILL DPP(DJ)
- SET DJ=DJ-1
- +9 DO SETDIC
- QUIT
- +10 ;
- SETDIC KILL DIC
- SET DIC="^DD(DL,"
- +1 SET DIC("S")="S %=$P(^(0),U,2) I %'[""m"",$S('%:1,1:$P(^DD(+%,.01,0),U,2)'[""W""&$S($D(DIL(+%)):DIL(+%)=DL,1:1))"_$SELECT($DATA(DICS):" "_DICS,1:"")
- SET DIC("W")="W:$P(^(0),U,2) "" (multiple)"""
- SET DIC(0)="ZE"_$EXTRACT("O",$DATA(DIPP)#10)
- QUIT
- +2 ;
- DIC DO SETDIC
- DO ^DIC
- DO DIP^DIQQ
- QUIT