DIP22 ;SFISC/GFT-EDIT PRINT TEMPLATE ;09:03 AM 21 Aug 2002 [ 12/09/2003 4:17 PM ]
;;22.0;VA FileMan;**2,43,97,113,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
S DC(1)=$O(^DIPT(DC(0),"F",DC(1))),DC=0 Q:DC(1)="" S DC=2,DY=^(DC(1)),Y=2
Y S X=$P(DY,$C(126)),DY=$P(DY,$C(126),2,99) I X="" G DIP22:'$D(DC(2)) Q
I D9]"" G UP:$P(X,D9)]"" S X=$P(X,D9,2,99)
R I X'>0 G 0:$E(X,2)'=","&'X S:+X D9=D9_+X_",",DRK=-X G M
I X["," S DA=$P(X,",") I +DA=DA S:DA<0 DA=-DA G Y:'$D(^DD(DRK,DA,0)) S X=$P(X,",",2,99),DC(Y)=$P(^(0),U),%=+X,D=+$P(^(0),U,2) G Y:'$D(^DD(D,.01,0)),W:$P(^(0),U,2)["W" S DRK=D,Y=Y+1,D9=D9_DA_"," G R
S %=+X,D=DRK_U_% D DCL
G Y:'$D(^DD(DRK,%,0))
W S X=$P(^(0),U)_$E(X,$L(%)+1,999)
P D S DC(Y)=X,Y=Y+1 G Y
.N % F S %=$F(X,";;") Q:'% S X=$E(X,1,%-2)_$E(X,%,9999)
0 S:X?1"0".E X=$S($D(^DD(DRK,.001,0)):$P(^(0),U,1),1:"NUMBER")_$E(X,2,999) I P]"" S D=DRK_"^0" D DCL
M S %=$F(X,";Z;""") G P:'% S %=%-$L($P(X,";",1)),X=";"_$P(X,";",2,99) F D=%:0 S D=$F(X,"""",D) I ";"[$E(X,D) S X=$E(X,%,D-2)_$E(X,1,%-5)_$E(X,D,999) G P
;
UP S DRK=J(0),%=D9,DA=""
DOWN I X[",",+X=$P(X,","),$P(D9,DA_+X_",")="" S DA=DA_+X_",",%=$P(%,",",2,99),DRK=$S(X'>0:-X,1:+$P(^DD(DRK,+X,0),U,2)),X=$P(X,",",2,99) G DOWN
NUL S D9=DA,DC(Y)="",Y=Y+1,%=$P(%,",",2,99) G NUL:%]"",R
;
X ;who comes here??
S DC(1)=DD D Y F D=2:1 Q:'$D(DC(D)) S X=DC(D) X DICMX I '$D(D) K DD Q
Q
;
HARD ;
S DM=X,DQI="DIP(",DA="DXS("_DXS_",",S=S_";Z;"""_X_"""",DICOMP=DIL_$E("?",''L)_"TI"
S DICOMPX="" G JUMP:X?.E1":"
S DICMX="X DICMX" D EN^DICOMP I '$D(X) G QQ:'$D(FLDS) S X=DM D ^DIM G QQ:'$D(X) S Y="X"
D FLY G S^DIP2
;
JUMP S DICMX="S DIXX=DIXX("_DL_") D M" D ^DICOMPW
I $D(X) S %=Y D OVFL,F S S=U_$P(DP,U,2)_U_$E(1,%["m")_U_S,X=1,P="",DIL(DL)=DIL,DV(DL)=DV,DL(DL)=DK,DK=+DP,DV=DV_-DP_",",Y=0,DL=DL+1,DIL=+% K P G S^DIP2
QQ ;
W $C(7),"??" G F^DIP2
;
FLY ;
S:'$D(X) X=DM S %=Y["D"
I % S:S'[";d" S=S_";d" I S'[";R",S'[";L",$G(DDXP)'=2 S S=S_";L18"
I Y["W",S'[";X" S S=S_";X"
I Y["m" S:S'[";m" S=S_";m" I Y["w",S'[";w" S S=S_";w"
D OVFL I P="",Y'["X" S X=X_$S(S[";W":"",%:" S Y=X D DT",1:" W X")_" K DIP"
F S S=X_S S:P]"" S=S_";"_P
DXS F Y=0:0 S Y=$O(X(Y)) Q:Y="" S DXS(DXS,Y)=X(Y)
S DXS=$D(X)>1+DXS K DATE,X Q
;
OVFL I $L(X)+$L(S)>180 S X(9)=X,X="X DXS("_DXS_",9)"
Q
DIC I X="NUMBER" S Y=X G B:'$D(DIAR),B:DIAR'=4,B:'$D(DC(DC))
E D ^DIC G E:'$D(DIAR),E:DIAR'=4,E:'$D(DC(DC)),RTN^DIP2:$E(X)="?"
G E:'DC,E:$P(X,";")=$P(DC(DC),";"),E:$P($P(Y,U,2),";")=$P(DC(DC),";")
Z W !,$C(7),"Because this is an ARCHIVING process:"
W !!,"You may ADD fields to output or CHANGE PREDEFINED FIELD formats"
W !,"but NOT change, delete or do calculations on predefined fields.",!
G 2^DIP2
E I $D(Y) G GF^DIP2:Y>0
G UP^DIP2:X="",^DIP21:X?1"[".E&(DE="")
B D G:'$D(D) DIC S X=$RE(X) D S X=$RE(X) G:'$D(D) DIC ;from beginning, then end
.F D="+","#","*","&","!" I $E(X)=D S P=D,X=$E(X,2,999) K D Q
I X[";" S S=";"_$P(X,";",2,99)_S,X=$P(X,";") G DIC
I $E(X)="]" S X=$E(X,2,999),DALL(1)=1 G DIC
G RTN^DIP2
;
DCL I $D(^DIPT(DC(0),"DCL",D)) S X=X_$E(^(D),$L(^(D)))
Q
DIP22 ;SFISC/GFT-EDIT PRINT TEMPLATE ;09:03 AM 21 Aug 2002 [ 12/09/2003 4:17 PM ]
+1 ;;22.0;VA FileMan;**2,43,97,113,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET DC(1)=$ORDER(^DIPT(DC(0),"F",DC(1)))
SET DC=0
IF DC(1)=""
QUIT
SET DC=2
SET DY=^(DC(1))
SET Y=2
Y SET X=$PIECE(DY,$CHAR(126))
SET DY=$PIECE(DY,$CHAR(126),2,99)
IF X=""
IF '$DATA(DC(2))
GOTO DIP22
QUIT
+1 IF D9]""
IF $PIECE(X,D9)]""
GOTO UP
SET X=$PIECE(X,D9,2,99)
R IF X'>0
IF $EXTRACT(X,2)'=","&'X
GOTO 0
IF +X
SET D9=D9_+X_","
SET DRK=-X
GOTO M
+1 IF X[","
SET DA=$PIECE(X,",")
IF +DA=DA
IF DA<0
SET DA=-DA
IF '$DATA(^DD(DRK,DA,0))
GOTO Y
SET X=$PIECE(X,",",2,99)
SET DC(Y)=$PIECE(^(0),U)
SET %=+X
SET D=+$PIECE(^(0),U,2)
IF '$DATA(^DD(D,.01,0))
GOTO Y
IF $PIECE(^(0),U,2)["W"
GOTO W
SET DRK=D
SET Y=Y+1
SET D9=D9_DA_","
GOTO R
+2 SET %=+X
SET D=DRK_U_%
DO DCL
+3 IF '$DATA(^DD(DRK,%,0))
GOTO Y
W SET X=$PIECE(^(0),U)_$EXTRACT(X,$LENGTH(%)+1,999)
P Begin DoDot:1
+1 NEW %
FOR
SET %=$FIND(X,";;")
IF '%
QUIT
SET X=$EXTRACT(X,1,%-2)_$EXTRACT(X,%,9999)
End DoDot:1
SET DC(Y)=X
SET Y=Y+1
GOTO Y
0 IF X?1"0".E
SET X=$SELECT($DATA(^DD(DRK,.001,0)):$PIECE(^(0),U,1),1:"NUMBER")_$EXTRACT(X,2,999)
IF P]""
SET D=DRK_"^0"
DO DCL
M SET %=$FIND(X,";Z;""")
IF '%
GOTO P
SET %=%-$LENGTH($PIECE(X,";",1))
SET X=";"_$PIECE(X,";",2,99)
FOR D=%:0
SET D=$FIND(X,"""",D)
IF ";"[$EXTRACT(X,D)
SET X=$EXTRACT(X,%,D-2)_$EXTRACT(X,1,%-5)_$EXTRACT(X,D,999)
GOTO P
+1 ;
UP SET DRK=J(0)
SET %=D9
SET DA=""
DOWN IF X[","
IF +X=$PIECE(X,",")
IF $PIECE(D9,DA_+X_",")=""
SET DA=DA_+X_","
SET %=$PIECE(%,",",2,99)
SET DRK=$SELECT(X'>0:-X,1:+$PIECE(^DD(DRK,+X,0),U,2))
SET X=$PIECE(X,",",2,99)
GOTO DOWN
NUL SET D9=DA
SET DC(Y)=""
SET Y=Y+1
SET %=$PIECE(%,",",2,99)
IF %]""
GOTO NUL
GOTO R
+1 ;
X ;who comes here??
+1 SET DC(1)=DD
DO Y
FOR D=2:1
IF '$DATA(DC(D))
QUIT
SET X=DC(D)
XECUTE DICMX
IF '$DATA(D)
KILL DD
QUIT
+2 QUIT
+3 ;
HARD ;
+1 SET DM=X
SET DQI="DIP("
SET DA="DXS("_DXS_","
SET S=S_";Z;"""_X_""""
SET DICOMP=DIL_$EXTRACT("?",''L)_"TI"
+2 SET DICOMPX=""
IF X?.E1":"
GOTO JUMP
+3 SET DICMX="X DICMX"
DO EN^DICOMP
IF '$DATA(X)
IF '$DATA(FLDS)
GOTO QQ
SET X=DM
DO ^DIM
IF '$DATA(X)
GOTO QQ
SET Y="X"
+4 DO FLY
GOTO S^DIP2
+5 ;
JUMP SET DICMX="S DIXX=DIXX("_DL_") D M"
DO ^DICOMPW
+1 IF $DATA(X)
SET %=Y
DO OVFL
DO F
SET S=U_$PIECE(DP,U,2)_U_$EXTRACT(1,%["m")_U_S
SET X=1
SET P=""
SET DIL(DL)=DIL
SET DV(DL)=DV
SET DL(DL)=DK
SET DK=+DP
SET DV=DV_-DP_","
SET Y=0
SET DL=DL+1
SET DIL=+%
KILL P
GOTO S^DIP2
QQ ;
+1 WRITE $CHAR(7),"??"
GOTO F^DIP2
+2 ;
FLY ;
+1 IF '$DATA(X)
SET X=DM
SET %=Y["D"
+2 IF %
IF S'[";d"
SET S=S_";d"
IF S'[";R"
IF S'[";L"
IF $GET(DDXP)'=2
SET S=S_";L18"
+3 IF Y["W"
IF S'[";X"
SET S=S_";X"
+4 IF Y["m"
IF S'[";m"
SET S=S_";m"
IF Y["w"
IF S'[";w"
SET S=S_";w"
+5 DO OVFL
IF P=""
IF Y'["X"
SET X=X_$SELECT(S[";W":"",%:" S Y=X D DT",1:" W X")_" K DIP"
F SET S=X_S
IF P]""
SET S=S_";"_P
DXS FOR Y=0:0
SET Y=$ORDER(X(Y))
IF Y=""
QUIT
SET DXS(DXS,Y)=X(Y)
+1 SET DXS=$DATA(X)>1+DXS
KILL DATE,X
QUIT
+2 ;
OVFL IF $LENGTH(X)+$LENGTH(S)>180
SET X(9)=X
SET X="X DXS("_DXS_",9)"
+1 QUIT
DIC IF X="NUMBER"
SET Y=X
IF '$DATA(DIAR)
GOTO B
IF DIAR'=4
GOTO B
IF '$DATA(DC(DC))
GOTO B
+1 IF '$TEST
DO ^DIC
IF '$DATA(DIAR)
GOTO E
IF DIAR'=4
GOTO E
IF '$DATA(DC(DC))
GOTO E
IF $EXTRACT(X)="?"
GOTO RTN^DIP2
+2 IF 'DC
GOTO E
IF $PIECE(X,";")=$PIECE(DC(DC),";")
GOTO E
IF $PIECE($PIECE(Y,U,2),";")=$PIECE(DC(DC),";")
GOTO E
Z WRITE !,$CHAR(7),"Because this is an ARCHIVING process:"
+1 WRITE !!,"You may ADD fields to output or CHANGE PREDEFINED FIELD formats"
+2 WRITE !,"but NOT change, delete or do calculations on predefined fields.",!
+3 GOTO 2^DIP2
E IF $DATA(Y)
IF Y>0
GOTO GF^DIP2
+1 IF X=""
GOTO UP^DIP2
IF X?1"[".E&(DE="")
GOTO ^DIP21
B ;from beginning, then end
Begin DoDot:1
+1 FOR D="+","#","*","&","!"
IF $EXTRACT(X)=D
SET P=D
SET X=$EXTRACT(X,2,999)
KILL D
QUIT
End DoDot:1
IF '$DATA(D)
GOTO DIC
SET X=$REVERSE(X)
Begin DoDot:1
End DoDot:1
SET X=$REVERSE(X)
IF '$DATA(D)
GOTO DIC
+2 IF X[";"
SET S=";"_$PIECE(X,";",2,99)_S
SET X=$PIECE(X,";")
GOTO DIC
+3 IF $EXTRACT(X)="]"
SET X=$EXTRACT(X,2,999)
SET DALL(1)=1
GOTO DIC
+4 GOTO RTN^DIP2
+5 ;
DCL IF $DATA(^DIPT(DC(0),"DCL",D))
SET X=X_$EXTRACT(^(D),$LENGTH(^(D)))
+1 QUIT
