DIP22 ;SFISC/GFT-EDIT PRINT TEMPLATE ;16MAR2010
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
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)):$$LABEL^DIALOGZ(DRK,.001),1:$$EZBLD^DIALOG(7099))_$E(X,2,999) I P]"" S D=DRK_"^0" D DCL ;**CCO/NI COLUMN HEADING FOR NUMBER FIELD
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^DIO2" D ^DICOMPW ;DICMX COULD BE INVOKED INSIDE SOME ROUTINE
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!(X[";") S X(9)=X,X="X DXS("_DXS_",9)"
Q
;
DIC I X=$$EZBLD^DIALOG(7099) S Y=X G B:'$D(DIAR),B:DIAR'=4,B:'$D(DC(DC)) ;**CCO/NI 'NUMBER'
E D DICW^DIALOGZ(DK),^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 $G(Y)>0 D:$G(S)[";B" G GF^DIP2
.N I S I=+$P(Y(0),U,2) I I,$D(^DD(I,0,"IX","B")) Q ;B is good if multiple has B x-ref
.I +Y=.01,'$D(^DIC(DK)),$D(^DD(DK,0,"IX","B")) Q
.S I=$F(S,";B"),S=$E(S,1,I-3)_$E(S,I,999) ;otherwise strip it out
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIP22 3687 printed Dec 13, 2024@02:52:44 Page 2
DIP22 ;SFISC/GFT-EDIT PRINT TEMPLATE ;16MAR2010
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 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 ;**CCO/NI COLUMN HEADING FOR NUMBER FIELD
if X?1"0".E
SET X=$SELECT($DATA(^DD(DRK,.001,0)):$$LABEL^DIALOGZ(DRK,.001),1:$$EZBLD^DIALOG(7099))_$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 ;DICMX COULD BE INVOKED INSIDE SOME ROUTINE
SET DICMX="S DIXX=DIXX("_DL_") D M^DIO2"
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!(X[";")
SET X(9)=X
SET X="X DXS("_DXS_",9)"
+1 QUIT
+2 ;
DIC ;**CCO/NI 'NUMBER'
IF X=$$EZBLD^DIALOG(7099)
SET Y=X
if '$DATA(DIAR)
GOTO B
if DIAR'=4
GOTO B
if '$DATA(DC(DC))
GOTO B
+1 IF '$TEST
DO DICW^DIALOGZ(DK)
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 $GET(Y)>0
if $GET(S)[";B"
Begin DoDot:1
+1 ;B is good if multiple has B x-ref
NEW I
SET I=+$PIECE(Y(0),U,2)
IF I
IF $DATA(^DD(I,0,"IX","B"))
QUIT
+2 IF +Y=.01
IF '$DATA(^DIC(DK))
IF $DATA(^DD(DK,0,"IX","B"))
QUIT
+3 ;otherwise strip it out
SET I=$FIND(S,";B")
SET S=$EXTRACT(S,1,I-3)_$EXTRACT(S,I,999)
End DoDot:1
GOTO GF^DIP2
+4 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
