- 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
