XBKD1.m

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       ;