- DIPZ1 ;SFISC/GFT,XAK-COMPILE PRINT TEMPLATES ;30JAN2003
- ;;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.
- ;
- PX ;
- F DX=DX+1:1 I '$D(^UTILITY("DIPZ",$J,DX)) S ^(DX)=" "_$E(Y,2,999) Q
- W:'$G(DIPZS) "." S O=0,DIPZL=$L(Y)+DIPZL+2 I DIPZL>DMAX S DRN(DRN)=DX,^(DX+1)=^(DX),DIPZL=$L(Y)+2,DRN=DRN+1,^(DX)=" G ^"_DNM_DRN,DX=DX+1
- Q
- ;
- DE ;
- D SUBNAME S DX=F(DM-1),^(DX)=^(DX)_" D "_X
- D S DIPZL(DM)=DX+1,DIPZLR(DM)=DRN,^(DX+1)=" G "_X_"R",^(DX+2)=X_" ;",DX=DX+2 Q
- ;
- DIWR ;
- S I=$D(^UTILITY("DIPZ",$J,1)) I $D(DIWR(DM)),DX=DIWR(DM) S ^(DX)=" D A^DIWW"
- E I $D(DIWR(DM)) S DX=DX+1,^(DX)=" D ^DIWW"
- E F I=DM-1:-1:0 I $D(DIWR(I)) K DIWR(I) S I=F(I),^(I-.1)=" D ^DIWW" Q
- K DIWR(DM) Q
- ;
- WP ;
- S I=$E(^UTILITY("DIPZ",$J,X),2,999) D WPX^DIL0 S ^UTILITY("DIPZ",$J,X)=" "_I Q
- ;
- DREL ;
- S %=X,DHT=Y,DM=DM+1 D SUBNAME F DX=DX+1:1 I '$D(^UTILITY("DIPZ",$J,DX)) S ^(DX)=" S DICMX=""D "_X_U_DNM_""",DIXX("_DM_")="""_X_""""_% Q
- D D S DX=DX+2,^(DX-1)=" I $D(DSC("_DP_")) X DSC("_DP_") E Q",^(DX)=" W:$X>"_DG_" !"_DHT,DHT=-1,F=F_+W_C,DIL=DIL+1,DD=DD-1,%=DX Q
- ;
- UP ;
- S ^UTILITY("DIPZ",$J,DX+1)=" Q",X=DIPZ(DM) D X
- S (F(DM-1),DX)=DX+2,^UTILITY("DIPZ",$J,DX)=X_"R ;" S:DIPZLR(DM)'=DRN ^(DIPZL(DM))=^(DIPZL(DM))_"^"_DNM_DRN Q
- ;
- SUBNAME S (DIPZ(DM),X)=$G(DIPZ(DM))+1
- X S X=$S(X<27:$C(64+X),1:$C(X\26+64,X#26+65))_DM Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIPZ1 1585 printed Feb 19, 2025@00:19:45 Page 2
- DIPZ1 ;SFISC/GFT,XAK-COMPILE PRINT TEMPLATES ;30JAN2003
- +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 ;
- PX ;
- +1 FOR DX=DX+1:1
- IF '$DATA(^UTILITY("DIPZ",$JOB,DX))
- SET ^(DX)=" "_$EXTRACT(Y,2,999)
- QUIT
- +2 if '$GET(DIPZS)
- WRITE "."
- SET O=0
- SET DIPZL=$LENGTH(Y)+DIPZL+2
- IF DIPZL>DMAX
- SET DRN(DRN)=DX
- SET ^(DX+1)=^(DX)
- SET DIPZL=$LENGTH(Y)+2
- SET DRN=DRN+1
- SET ^(DX)=" G ^"_DNM_DRN
- SET DX=DX+1
- +3 QUIT
- +4 ;
- DE ;
- +1 DO SUBNAME
- SET DX=F(DM-1)
- SET ^(DX)=^(DX)_" D "_X
- D SET DIPZL(DM)=DX+1
- SET DIPZLR(DM)=DRN
- SET ^(DX+1)=" G "_X_"R"
- SET ^(DX+2)=X_" ;"
- SET DX=DX+2
- QUIT
- +1 ;
- DIWR ;
- +1 SET I=$DATA(^UTILITY("DIPZ",$JOB,1))
- IF $DATA(DIWR(DM))
- IF DX=DIWR(DM)
- SET ^(DX)=" D A^DIWW"
- +2 IF '$TEST
- IF $DATA(DIWR(DM))
- SET DX=DX+1
- SET ^(DX)=" D ^DIWW"
- +3 IF '$TEST
- FOR I=DM-1:-1:0
- IF $DATA(DIWR(I))
- KILL DIWR(I)
- SET I=F(I)
- SET ^(I-.1)=" D ^DIWW"
- QUIT
- +4 KILL DIWR(DM)
- QUIT
- +5 ;
- WP ;
- +1 SET I=$EXTRACT(^UTILITY("DIPZ",$JOB,X),2,999)
- DO WPX^DIL0
- SET ^UTILITY("DIPZ",$JOB,X)=" "_I
- QUIT
- +2 ;
- DREL ;
- +1 SET %=X
- SET DHT=Y
- SET DM=DM+1
- DO SUBNAME
- FOR DX=DX+1:1
- IF '$DATA(^UTILITY("DIPZ",$JOB,DX))
- SET ^(DX)=" S DICMX=""D "_X_U_DNM_""",DIXX("_DM_")="""_X_""""_%
- QUIT
- +2 DO D
- SET DX=DX+2
- SET ^(DX-1)=" I $D(DSC("_DP_")) X DSC("_DP_") E Q"
- SET ^(DX)=" W:$X>"_DG_" !"_DHT
- SET DHT=-1
- SET F=F_+W_C
- SET DIL=DIL+1
- SET DD=DD-1
- SET %=DX
- QUIT
- +3 ;
- UP ;
- +1 SET ^UTILITY("DIPZ",$JOB,DX+1)=" Q"
- SET X=DIPZ(DM)
- DO X
- +2 SET (F(DM-1),DX)=DX+2
- SET ^UTILITY("DIPZ",$JOB,DX)=X_"R ;"
- if DIPZLR(DM)'=DRN
- SET ^(DIPZL(DM))=^(DIPZL(DM))_"^"_DNM_DRN
- QUIT
- +3 ;
- SUBNAME SET (DIPZ(DM),X)=$GET(DIPZ(DM))+1
- X SET X=$SELECT(X<27:$CHAR(64+X),1:$CHAR(X\26+64,X#26+65))_DM
- QUIT
