- XBKD1 ; IHS/ADC/GTH - XBKD SUBROUTINES ; [ 02/07/97 3:02 PM ]
- ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
- ;
- ; Part of XBKD
- ;
- BX ;
- KILL A
- S (I,C)=""
- F J=1:1 S I=$O(^DIC("B",I)) Q:I="" I $D(^(I,N)) S C=C+1,A(C)=I
- I 'C S C=$O(^DD(N,"NM","")) I C]"" S A=C,C=1,A(C)=A
- Q
- ;
- NCK ;
- G NCKER:'$D(^DIC(N,0)),NCKER:+$P(^(0),"^",2)'=N
- I $D(^DIC(N,0,"GL")) S G=^("GL") G NCKOK:G?1"^DIC(".E
- I @("$D("_G_"0))"),+$P(^(0),"^",2)=N G NCKOK
- NCKER ;
- S E=1
- Q
- ;
- NCKOK ;
- S E=0
- Q
- ;
- FGLB ;
- G FGOK:'$D(^DD(N,.01,1))
- S I=0
- F J=1:1 S I=$O(^DD(N,.01,1,I)) Q:I="" I $D(^(I,1)) S X=^(1) D SB1 G FGOK:G]""
- S G=""
- FGOK ;
- Q
- ;
- END ;
- Q
- ;
- TEMPLP ;
- F TEMP="^DIE(","^DIBT(","^DIPT(" D TEMP
- Q
- ;
- TEMP ;
- S XBKDB="F"_XBKDFILE,XBKDA=""
- TEMP1 ;
- S @("XBKDA=$O("_TEMP_"XBKDB,XBKDA))")
- G TEMPE:XBKDA=""
- S DA=""
- TEMP2 ;
- S @("DA=$O("_TEMP_"XBKDB,XBKDA,DA))")
- G TEMP1:DA=""
- S DIE=TEMP,DR=".01" ;D ^DIE
- W !,DIE,?8,DA,?12,XBKDB,?24,XBKDA
- G TEMP2
- ;
- TEMPE ;
- KILL XBKDA,XBKDB
- Q
- ;
- SB1 ;
- S G=""
- I X'?1"S ^"1UP.U1"(".N1",""B""".E
- S G=$E($P(X,"""B""",1),3,999)
- Q
- ;
- XBKD1 ; IHS/ADC/GTH - XBKD SUBROUTINES ; [ 02/07/97 3:02 PM ]
- +1 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
- +2 ;
- +3 ; Part of XBKD
- +4 ;
- BX ;
- +1 KILL A
- +2 SET (I,C)=""
- +3 FOR J=1:1
- SET I=$ORDER(^DIC("B",I))
- IF I=""
- QUIT
- IF $DATA(^(I,N))
- SET C=C+1
- SET A(C)=I
- +4 IF 'C
- SET C=$ORDER(^DD(N,"NM",""))
- IF C]""
- SET A=C
- SET C=1
- SET A(C)=A
- +5 QUIT
- +6 ;
- NCK ;
- +1 IF '$DATA(^DIC(N,0))
- GOTO NCKER
- IF +$PIECE(^(0),"^",2)'=N
- GOTO NCKER
- +2 IF $DATA(^DIC(N,0,"GL"))
- SET G=^("GL")
- IF G?1"^DIC(".E
- GOTO NCKOK
- +3 IF @("$D("_G_"0))")
- IF +$PIECE(^(0),"^",2)=N
- GOTO NCKOK
- NCKER ;
- +1 SET E=1
- +2 QUIT
- +3 ;
- NCKOK ;
- +1 SET E=0
- +2 QUIT
- +3 ;
- FGLB ;
- +1 IF '$DATA(^DD(N,.01,1))
- GOTO FGOK
- +2 SET I=0
- +3 FOR J=1:1
- SET I=$ORDER(^DD(N,.01,1,I))
- IF I=""
- QUIT
- IF $DATA(^(I,1))
- SET X=^(1)
- DO SB1
- IF G]""
- GOTO FGOK
- +4 SET G=""
- FGOK ;
- +1 QUIT
- +2 ;
- END ;
- +1 QUIT
- +2 ;
- TEMPLP ;
- +1 FOR TEMP="^DIE(","^DIBT(","^DIPT("
- DO TEMP
- +2 QUIT
- +3 ;
- TEMP ;
- +1 SET XBKDB="F"_XBKDFILE
- SET XBKDA=""
- TEMP1 ;
- +1 SET @("XBKDA=$O("_TEMP_"XBKDB,XBKDA))")
- +2 IF XBKDA=""
- GOTO TEMPE
- +3 SET DA=""
- TEMP2 ;
- +1 SET @("DA=$O("_TEMP_"XBKDB,XBKDA,DA))")
- +2 IF DA=""
- GOTO TEMP1
- +3 ;D ^DIE
- SET DIE=TEMP
- SET DR=".01"
- +4 WRITE !,DIE,?8,DA,?12,XBKDB,?24,XBKDA
- +5 GOTO TEMP2
- +6 ;
- TEMPE ;
- +1 KILL XBKDA,XBKDB
- +2 QUIT
- +3 ;
- SB1 ;
- +1 SET G=""
- +2 IF X'?1"S ^"1UP.U1"(".N1",""B""".E
- +3 SET G=$EXTRACT($PIECE(X,"""B""",1),3,999)
- +4 QUIT
- +5 ;
