- DIP2 ;SFISC/GFT-PRINT FLDS OR TEMPLATES ;2/10/94 09:48
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- K ^UTILITY("DIP2",$J),DG,K,DISH,DIL,DXS,A,P,I,J S I(0)=DI,(DE,DINS,DV,DNP)="",(DXS,DL,R)=1,(DIPT,DJ,DCL,DIL)=0,DK=+$P(@(DI_"0)"),U,2),J(0)=DK
- EN ;
- ;I $D(DIAR),'$D(DIARP(DIARF)) G DIP2^DIARA:DIAR=1 D DIP2^DIARA
- F S (P,S)=""
- 1 ;G B:DC,B:DE'="",B:'$D(FLDS)
- ;S DC=0,(X,DU)=FLDS
- ;G ^DIP21
- B S DU=$P(^DD(DK,0),U) I DL>1 S:DU="FIELD" DU=$O(^(0,"NM",0))_" "_DU I $O(^($O(^DD(DK,0))))'>0,$P(^(.01,0),U,2)["W" S:'DINS&DC DC=DC-2 S Y=.01 D P G N
- K DIC,Y K:$D(DALL)<9 DALL I ('L!($G(DDXP)=4)),$D(FLDS) S X=$P(FLDS,C,R),R=R+1 G LIT
- I DC D ^DIP22:'$D(DC(DC))
- 2 W !?DL+DL-2,$S(DE]""!($D(DJ)>9):"THEN",1:"FIRST")_$S($G(DDXP)=2:" EXPORT ",1:" PRINT ")_DU_": "
- I DC W DC(DC) D RW G Q^DIP:X=U!($D(DTOUT)) S DINS=X?1"^"1E.E,X=$S(DINS:$E(X,2,999),X="":DC(DC),1:X) S:DC(DC)=""&$L(X) DINS=1 G XPCK
- I $D(DIRPIPE) X DIRPIPE G LIT
- R X:DTIME S:'$T X=U G Q^DIP:X=U
- I X="ALL",DE="",$D(DJ)<2 D G:$D(DIRUT) Q^DIP D:Y&($G(DDXP)=2) VALALL^DDXP2 G N:Y,F:'$D(X) W !?10,X
- . S DIR(0)="YA",DIR("A")=" Do you mean ALL the fields in the file? ",DIR("B")="NO",DIR("?")="Choose YES for every field in the file; NO for a field starting with 'ALL'",%XX=X
- . D ^DIR S X=%XX K DIR,%XX S:$D(DIRUT) X=U Q
- XPCK I $G(DDXP)=2 D VAL1^DDXP2 G:'$D(X) F
- LIT I $E(X)="""",$L(X,"""")#2 F A9=3:2:$L(X,Q) Q:$P(X,Q,A9)]""&($E($P(X,Q,A9)'=$C(95)))
- I I $P($P(X,Q,A9),";")="" K A9 S S=X G S:DINS,S:'$D(DIAR),S:DIAR'=4,S:'$D(DC(DC)),S:DC=0,Z^DIP22
- S DIC="^DD(DK,",DIC(0)=$E("ZE",1,'$D(FLDS)!''L+1)_$E("O",1,DC>0),DIC("W")="S %=$P(^(0),U,2) I % W $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" S:$D(DICS) DIC("S")=DICS
- DIC G DIC^DIP22
- RTN I DC,X="@" D DC G F
- G DIP2^DIQQ:X?."?",Q^DIP:X=U I $P("NUMBER",X,1)="" W $P("NUMBER",X,2) S S=0_S G S
- S DIC(0)="EYZ",D="GR" I $D(^DD(DK,D)) D IX^DIC G GF:Y>0 I 'Y F Y=0:0 S Y=$O(Y(Y)) G F:Y="" S X=^DD(DK,Y,0) D Y
- G HARD^DIP22
- ;
- GF I $G(DDXP)=2 D VAL2^DDXP2 G:'$D(Y(0)) F
- I $P(Y(0),U,2) D D,DC:DC S X=$P($P(Y(0),U,4),";",1),I(DIL)=$S(+X=X:X,1:Q_X_Q),J(DIL)=DK G 1
- I +Y=.001 S Y=0
- S S=+Y_S I P]"",$D(DCL(DK_U_+Y)) G QQ^DIP22
- S I $G(DDXP)=2 D VAL3^DDXP2 G:'$D(S) F
- D DJ G F
- ;
- D S DIL(DL)=DIL,DV(DL)=DV,DL(DL)=DK,DK=+$P(^DD(DK,+Y,0),U,2),DL=DL+1,DIL=DIL+1,DV=DV_+Y_C,Y=0 Q
- ;
- U S DL=DL-1,DV=DV(DL),DK=DL(DL),DIL=DIL(DL) F %=DIL:0 S %=$O(I(%)) Q:%="" K I(%),J(%)
- Q
- ;
- DC I 'DINS K:DC>1 DC(DC) S DC=DC+1
- Q
- ;
- Y S S=Y_S
- DJ I $L(DE)+$L(S)>150 S DJ=DJ+1,^UTILITY("DIP2",$J,DJ)=DE,DE=""
- S DE=DE_DV_S_$C(126),S="" D DC:DC
- P Q:'$D(P) I P="" K DNP Q
- I P="*" S DCL=DCL+1
- S DCL(DK_U_+Y)=$S($T:DCL_P,1:P) Q
- ;
- N S I=DL S:I=1 DALL=1
- NN S Y=.001 I $D(^DD(DK,Y)) S Y=0 D Y S Y=.001
- A S Y=$O(^DD(DK,Y)) I Y,$D(^(Y,8)),$D(DICS) X DICS E G A
- I Y'>0 G UP:I'<DL S Y=$P(DV,C,DL-1) D U G A
- I $P(^(0),U,2) D D G NN
- D Y G A
- ;
- UP K DIC I DL>1 D U,DC:DC G F
- I DE="",'DJ,'$D(DHIT),'$D(DIS) G F
- I $D(FLDS)>9 S X=$O(FLDS("")) I X]"" S FLDS=FLDS(X),R=1 K FLDS(X) G F
- G ^DIP3
- ;
- RW I $L(DC(DC))>19 S Y=DC(DC) D RW^DIR2 Q
- W "// " R X:DTIME S:'$T X=U,DTOUT=1 Q
- ;
- ER S (X,DU)="[CAPTIONED]" G ^DIP21
- DIP2 ;SFISC/GFT-PRINT FLDS OR TEMPLATES ;2/10/94 09:48
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 KILL ^UTILITY("DIP2",$JOB),DG,K,DISH,DIL,DXS,A,P,I,J
- SET I(0)=DI
- SET (DE,DINS,DV,DNP)=""
- SET (DXS,DL,R)=1
- SET (DIPT,DJ,DCL,DIL)=0
- SET DK=+$PIECE(@(DI_"0)"),U,2)
- SET J(0)=DK
- EN ;
- +1 ;I $DIP2_source.html#xD">D(DIP2_source.html#xD">DIAR),'$DIP2_source.html#xD">D(DIP2_source.html#xD">DIARP(DIP2_source.html#xD">DIARF)) G DIP2_source.html#xD">DIP2^DIP2_source.html#xD">DIARA:DIP2_source.html#xD">DIAR=1 DIP2_source.html#xD">D DIP2_source.html#xD">DIP2^DIP2_source.html#xD">DIARA
- F SET (P,S)=""
- 1 ;G B:DC,B:DE'="",B:'$D(FLDS)
- +1 ;S DC=0,(X,DU)=FLDS
- +2 ;G ^DIP21
- B SET DU=$PIECE(^DD(DK,0),U)
- IF DL>1
- IF DU="FIELD"
- SET DU=$ORDER(^(0,"NM",0))_" "_DU
- IF $ORDER(^($ORDER(^DD(DK,0))))'>0
- IF $PIECE(^(.01,0),U,2)["W"
- IF 'DINS&DC
- SET DC=DC-2
- SET Y=.01
- DO P
- GOTO N
- +1 KILL DIC,Y
- IF $DATA(DALL)<9
- KILL DALL
- IF ('L!($GET(DDXP)=4))
- IF $DATA(FLDS)
- SET X=$PIECE(FLDS,C,R)
- SET R=R+1
- GOTO LIT
- +2 IF DC
- IF '$DATA(DC(DC))
- DO ^DIP22
- 2 WRITE !?DL+DL-2,$SELECT(DE]""!($DATA(DJ)>9):"THEN",1:"FIRST")_$SELECT($GET(DDXP)=2:" EXPORT ",1:" PRINT ")_DU_": "
- +1 IF DC
- WRITE DC(DC)
- DO RW
- IF X=U!($DATA(DTOUT))
- GOTO Q^DIP
- SET DINS=X?1"^"1E.E
- SET X=$SELECT(DINS:$EXTRACT(X,2,999),X="":DC(DC),1:X)
- IF DC(DC)=""&$LENGTH(X)
- SET DINS=1
- GOTO XPCK
- +2 IF $DATA(DIRPIPE)
- XECUTE DIRPIPE
- GOTO LIT
- +3 READ X:DTIME
- IF '$TEST
- SET X=U
- IF X=U
- GOTO Q^DIP
- +4 IF X="ALL"
- IF DE=""
- IF $DATA(DJ)<2
- Begin DoDot:1
- +5 SET DIR(0)="YA"
- SET DIR("A")=" Do you mean ALL the fields in the file? "
- SET DIR("B")="NO"
- SET DIR("?")="Choose YES for every field in the file; NO for a field starting with 'ALL'"
- SET %XX=X
- +6 DO ^DIR
- SET X=%XX
- KILL DIR,%XX
- IF $DATA(DIRUT)
- SET X=U
- QUIT
- End DoDot:1
- IF $DATA(DIRUT)
- GOTO Q^DIP
- IF Y&($GET(DDXP)=2)
- DO VALALL^DDXP2
- IF Y
- GOTO N
- IF '$DATA(X)
- GOTO F
- WRITE !?10,X
- XPCK IF $GET(DDXP)=2
- DO VAL1^DDXP2
- IF '$DATA(X)
- GOTO F
- LIT IF $EXTRACT(X)=""""
- IF $LENGTH(X,"""")#2
- FOR A9=3:2:$LENGTH(X,Q)
- IF $PIECE(X,Q,A9)]""&($EXTRACT($PIECE(X,Q,A9)'=$CHAR(95)))
- QUIT
- +1 IF $TEST
- IF $PIECE($PIECE(X,Q,A9),";")=""
- KILL A9
- SET S=X
- IF DINS
- GOTO S
- IF '$DATA(DIAR)
- GOTO S
- IF DIAR'=4
- GOTO S
- IF '$DATA(DC(DC))
- GOTO S
- IF DC=0
- GOTO S
- GOTO Z^DIP22
- +2 SET DIC="^DD(DK,"
- SET DIC(0)=$EXTRACT("ZE",1,'$DATA(FLDS)!''L+1)_$EXTRACT("O",1,DC>0)
- P2_source.html#xS">SET DIC("W")="P2_source.html#xS">S %=$P2_source.html#xP">P(^(0),U,2) I % W $P2_source.html#xS">S($P2_source.html#xP">P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")"
- IF $DATA(DICS)
- SET DIC("S")=DICS
- DIC GOTO DIC^DIP22
- RTN IF DC
- IF X="@"
- DO DC
- GOTO F
- +1 IF X?."?"
- GOTO DIP2^DIQQ
- IF X=U
- GOTO Q^DIP
- IF $PIECE("NUMBER",X,1)=""
- WRITE $PIECE("NUMBER",X,2)
- SET S=0_S
- GOTO S
- +2 SET DIC(0)="EYZ"
- SET D="GR"
- IF $DATA(^DD(DK,D))
- DO IX^DIC
- IF Y>0
- GOTO GF
- IF 'Y
- FOR Y=0:0
- SET Y=$ORDER(Y(Y))
- IF Y=""
- GOTO F
- SET X=^DD(DK,Y,0)
- DO Y
- +3 GOTO HARD^DIP22
- +4 ;
- GF IF $GET(DDXP)=2
- DO VAL2^DDXP2
- IF '$DATA(Y(0))
- GOTO F
- +1 IF $PIECE(Y(0),U,2)
- DO D
- IF DC
- DO DC
- SET X=$PIECE($PIECE(Y(0),U,4),";",1)
- SET I(DIL)=$SELECT(+X=X:X,1:Q_X_Q)
- SET J(DIL)=DK
- GOTO 1
- +2 IF +Y=.001
- SET Y=0
- +3 SET S=+Y_S
- IF P]""
- IF $DATA(DCL(DK_U_+Y))
- GOTO QQ^DIP22
- S IF $GET(DDXP)=2
- DO VAL3^DDXP2
- IF '$DATA(S)
- GOTO F
- +1 DO DJ
- GOTO F
- +2 ;
- D SET DIL(DL)=DIL
- SET DV(DL)=DV
- SET DL(DL)=DK
- SET DK=+$PIECE(^DD(DK,+Y,0),U,2)
- SET DL=DL+1
- SET DIL=DIL+1
- SET DV=DV_+Y_C
- SET Y=0
- QUIT
- +1 ;
- U SET DL=DL-1
- SET DV=DV(DL)
- SET DK=DL(DL)
- SET DIL=DIL(DL)
- FOR %=DIL:0
- SET %=$ORDER(I(%))
- IF %=""
- QUIT
- KILL I(%),J(%)
- +1 QUIT
- +2 ;
- DC IF 'DINS
- IF DC>1
- KILL DC(DC)
- SET DC=DC+1
- +1 QUIT
- +2 ;
- Y SET S=Y_S
- DJ IF $LENGTH(DE)+$LENGTH(S)>150
- SET DJ=DJ+1
- SET ^UTILITY("DIP2",$JOB,DJ)=DE
- SET DE=""
- +1 SET DE=DE_DV_S_$CHAR(126)
- SET S=""
- IF DC
- DO DC
- P IF '$DATA(P)
- QUIT
- IF P=""
- KILL DNP
- QUIT
- +1 IF P="*"
- SET DCL=DCL+1
- +2 SET DCL(DK_U_+Y)=$SELECT($TEST:DCL_P,1:P)
- QUIT
- +3 ;
- N SET I=DL
- IF I=1
- SET DALL=1
- NN SET Y=.001
- IF $DATA(^DD(DK,Y))
- SET Y=0
- DO Y
- SET Y=.001
- A SET Y=$ORDER(^DD(DK,Y))
- IF Y
- IF $DATA(^(Y,8))
- IF $DATA(DICS)
- XECUTE DICS
- IF '$TEST
- GOTO A
- +1 IF Y'>0
- IF I'<DL
- GOTO UP
- SET Y=$PIECE(DV,C,DL-1)
- DO U
- GOTO A
- +2 IF $PIECE(^(0),U,2)
- DO D
- GOTO NN
- +3 DO Y
- GOTO A
- +4 ;
- UP KILL DIC
- IF DL>1
- DO U
- IF DC
- DO DC
- GOTO F
- +1 IF DE=""
- IF 'DJ
- IF '$DATA(DHIT)
- IF '$DATA(DIS)
- GOTO F
- +2 IF $DATA(FLDS)>9
- SET X=$ORDER(FLDS(""))
- IF X]""
- SET FLDS=FLDS(X)
- SET R=1
- KILL FLDS(X)
- GOTO F
- +3 GOTO ^DIP3
- +4 ;
- RW IF $LENGTH(DC(DC))>19
- SET Y=DC(DC)
- DO RW^DIR2
- QUIT
- +1 WRITE "// "
- READ X:DTIME
- IF '$TEST
- SET X=U
- SET DTOUT=1
- QUIT
- +2 ;
- ER SET (X,DU)="[CAPTIONED]"
- GOTO ^DIP21
