- DIPKINI1 ; ;10:28 AM 30 Mar 1999
- ;;22.0;VA FileMan;;Mar 30, 1999;Build 1
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ; LOADS AND INDEXES DD'S
- ;
- K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1
- S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q
- ASK ;I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q
- ;Q:'$D(DIFQ) S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q
- I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0 S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2
- D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD
- S DN="^DIPKI" F R=1:1:11 D @(DN_$$B36(R)) W "."
- F S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0 K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0 K ^(D) D IX
- DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0
- I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0)) S Z=^(0) D I^DITR
- K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA
- ;
- W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0))
- S %=1 Q
- S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W
- S:%=2 DIFQ(X)=0 K:%<0 DIFQ
- Q
- ;
- OPT ;OPTION
- RTN ;ROUTINE DOCUMENTATION NOTE
- FUN ;FUNCTION
- BUL ;BULLETIN
- KEY ;SECURITY KEY
- HEL ;HELP FRAME
- DIP ;PRINT TEMPLATE
- DIE ;INPUT TEMPLATE
- DIB ;SORT TEMPLATE
- DIS ;FORM
- REM ;REMOTE PROCEDURE
- ;
- SBF ;FILE AND SUB FILE NUMBERS
- IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK)
- S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
- I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK
- Q
- B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)
- N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIPKINI1 1981 printed Feb 19, 2025@00:19:14 Page 2
- DIPKINI1 ; ;10:28 AM 30 Mar 1999
- +1 ;;22.0;VA FileMan;;Mar 30, 1999;Build 1
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ; LOADS AND INDEXES DD'S
- +4 ;
- +5 KILL DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ
- DO DT^DICRW
- SET %=1
- SET U="^"
- SET DSEC=1
- +6 SET NO=$PIECE("I 0^I $D(@X)#2,X[U",U,%)
- IF %<1
- KILL DIFQ
- QUIT
- ASK ;I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q
- +1 ;Q:'$D(DIFQ) S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q
- +2 IF $DATA(DIFKEP)
- FOR DIDIU=0:0
- SET DIDIU=$ORDER(DIFKEP(DIDIU))
- if DIDIU'>0
- QUIT
- SET DIU=DIDIU
- SET DIU(0)=DIFKEP(DIDIU)
- DO EN^DIU2
- +3 DO DT^DICRW
- KILL ^UTILITY(U,$JOB),^UTILITY("DIK",$JOB)
- DO WAIT^DICD
- +4 SET DN="^DIPKI"
- FOR R=1:1:11
- DO @(DN_$$B36(R))
- WRITE "."
- +5 FOR
- SET D=$ORDER(^UTILITY(U,$JOB,"SBF",""))
- if D'>0
- QUIT
- if 'DIFQ(D)
- KILL ^(D)
- SET D=$ORDER(^(D,""))
- IF D>0
- KILL ^(D)
- DO IX
- DATA WRITE "."
- SET (D,DDF(1),DDT(0))=$ORDER(^UTILITY(U,$JOB,0))
- if D'>0
- QUIT
- +1 IF DIFQR(D)
- SET DTO=0
- SET DMRG=1
- SET DTO(0)=^(D)
- SET Z=^(D)_"0)"
- SET D0=^(D,0)
- SET @Z=D0
- SET DFR(1)="^UTILITY(U,$J,DDF(1),D0,"
- SET DKP=DIFQR(D)'=2
- FOR D0=0:0
- SET D0=$ORDER(^UTILITY(U,$JOB,DDF(1),D0))
- if D0=""
- SET D0=-1
- if '$DATA(^(D0,0))
- QUIT
- SET Z=^(0)
- DO I^DITR
- +2 KILL ^UTILITY(U,$JOB,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN
- GOTO DATA
- +3 ;
- W SET Y=$PIECE($TEXT(@X),";",2)
- WRITE !,"NOTE: This package also contains "_Y_"S",!
- if '$DATA(DIFQ(0))
- QUIT
- +1 SET %=1
- QUIT
- +2 SET %=1
- WRITE ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME"
- DO YN^DICN
- IF '%
- WRITE !?6,"Answer YES to replace the current "_Y_"S with the incoming ones."
- GOTO W
- +3 if %=2
- SET DIFQ(X)=0
- if %<0
- KILL DIFQ
- +4 QUIT
- +5 ;
- OPT ;OPTION
- RTN ;ROUTINE DOCUMENTATION NOTE
- FUN ;FUNCTION
- BUL ;BULLETIN
- KEY ;SECURITY KEY
- HEL ;HELP FRAME
- DIP ;PRINT TEMPLATE
- DIE ;INPUT TEMPLATE
- DIB ;SORT TEMPLATE
- DIS ;FORM
- REM ;REMOTE PROCEDURE
- +1 ;
- SBF ;FILE AND SUB FILE NUMBERS
- IX WRITE "."
- SET DIK="A"
- FOR %=0:0
- SET DIK=$ORDER(^DD(D,DIK))
- if DIK=""
- QUIT
- KILL ^(DIK)
- +1 SET DA(1)=D
- SET DIK="^DD("_D_","
- DO IXALL^DIK
- +2 IF $DATA(^DIC(D,"%",0))
- SET DIK="^DIC(D,""%"","
- GOTO IXALL^DIK
- +3 QUIT
- B36(X) QUIT $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)
- N(%) QUIT $EXTRACT("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)
