- FBAASKR ;WIOFO/LKG - SECURITY KEY REPORT ;1/29/15 11:27
- ;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
- ;;Per VA Directive 6402, this routine should not be modified.
- ; IAs
- ; #1340 Lookup Security Key file (#19.1) entries
- ; #4398 FIRST^VAUTOMA
- ; #10060 New Person File (#200) Read w/FileMan
- ; #10090 Institution File (#4) Read w/FileMan
- ; #10076 ^XUSEC GLOBAL
- ;
- ST ;
- N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y,FBABORT,FBACTIVE,FBRT,POP,VAUTSTR,VAUTNI,VAUTVB,FBKEY,FBUSER
- S DIR(0)="YB",DIR("A")="Should report include terminated users with keys",DIR("B")="NO"
- D ^DIR G:$D(DIRUT) END
- S FBACTIVE=$S('Y:1,1:0) K DIR
- S FBABORT=0
- S DIR(0)="SB^S:SECURITY KEY;U:USER",DIR("A")="Sort by Security Key or User"
- S DIR("?",1)="Enter 'S' to have report by Security Key or"
- S DIR("?")=" 'U' to have the report by User. Enter '^' to exit."
- S DIR("??")="^D EN^DDIOL(""The report is users listed by Security Key (S) or Keys listed by User (U)."","""",""!?2"")"
- D ^DIR
- G END:$D(DIRUT)
- S FBRT=Y
- I FBRT="S" D G END:FBABORT,DEV
- . N DIC S DIC="^DIC(19.1,",DIC("S")="I $E($P($G(^(0)),U),1,2)=""FB"",$E($P($G(^(0)),U),3)'=""Z"""
- . S VAUTSTR="Fee Basis Security Key",VAUTNI=2,VAUTVB="FBKEY"
- . D FIRST^VAUTOMA I Y=-1 S FBABORT=1
- . I FBKEY=1 D
- . . N FBARR,FBERR,FBI
- . . D LIST^DIC(19.1,"","","","","","FB","B","I $E($P($G(^(0)),U),1,3)'=""FBZ""","","FBARR","FBERR")
- . . F FBI=1:1:(+FBARR("DILIST",0)) S FBKEY(FBARR("DILIST",2,FBI))=FBARR("DILIST",1,FBI)
- I FBRT="U" D G END:FBABORT,DEV
- . N DIC S DIC="^VA(200,",VAUTSTR="User",VAUTNI=2,VAUTVB="FBUSER"
- . S:FBACTIVE DIC("S")="I '$$TERM^FBAASKR(Y)"
- . D FIRST^VAUTOMA I Y=-1 S FBABORT=1
- DEV ;Ask device
- S %ZIS="Q" D ^%ZIS G:POP END
- I $D(IO("Q")) D G END
- . N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
- . S ZTRTN="COMPILE^FBAASKR",ZTDESC="Security Key Report for Fee Basis"
- . S ZTSAVE("FBKEY")="",ZTSAVE("FBKEY(")="",ZTSAVE("FBUSER")="",ZTSAVE("FBUSER(")="",ZTSAVE("FBRT")="",ZTSAVE("FBACTIVE")=""
- . D ^%ZTLOAD,HOME^%ZIS
- COMPILE ;
- N DIR,DIRUT,DIROUT,DTOUT,DUOUT,FBABORT,FBDTR,FBLINE,FBLP,FBPAGE,X,Y
- S FBABORT=0,$P(FBLINE,"-",41)="",FBPAGE=0
- D NOW^%DTC S Y=% D DD^%DT S FBDTR=Y
- ;
- K ^TMP($J)
- I FBRT="S" D
- . N FBERR,FBI,FBJ,FBK,FBN S FBI=""
- . F S FBI=$O(FBKEY(FBI)) Q:'FBI D
- . . S FBJ=FBKEY(FBI)
- . . I '$D(^XUSEC(FBJ)) S ^TMP($J,FBJ,"No holders^0")="" Q
- . . S FBK=""
- . . F S FBK=$O(^XUSEC(FBJ,FBK)) Q:FBK="" D
- . . . I FBACTIVE,$$TERM(FBK) Q
- . . . S FBN=$$GET1^DIQ(200,FBK_",",.01,"","","FBERR") K FBERR
- . . . S ^TMP($J,FBJ,FBN_"^"_FBK)=""
- I FBRT="U" D
- . I FBUSER'=1 D Q
- . . N FBC,FBK,FBJ S FBK=""
- . . F S FBK=$O(FBUSER(FBK)) Q:FBK="" D
- . . . S FBJ="FA~",FBC=0
- . . . F S FBJ=$O(^XUSEC(FBJ)) Q:FBJ]"FBY~"!(FBJ="") D
- . . . . I $D(^XUSEC(FBJ,FBK)) S ^TMP($J,FBUSER(FBK)_"^"_FBK,FBJ)="",FBC=FBC+1
- . . . S:FBC=0 ^TMP($J,FBUSER(FBK)_"^"_FBK,"No Fee Basis Key Held")=""
- . I FBUSER=1 D
- . . N FBERR,FBJ,FBK,FBN
- . . S FBJ="FA~"
- . . F S FBJ=$O(^XUSEC(FBJ)) Q:FBJ]"FBY~"!(FBJ="") D
- . . . S FBK=0
- . . . F S FBK=$O(^XUSEC(FBJ,FBK)) Q:FBK="" D
- . . . . I FBACTIVE,$$TERM(FBK) Q
- . . . . S FBN=$$GET1^DIQ(200,FBK_",",".01","","","FBERR") K FBERR
- . . . . S ^TMP($J,FBN_"^"_FBK,FBJ)=""
- ;
- PRT ;Print report
- U IO D HDR
- N FBI,FBIOLD,FBDA,FBJ,FBK,FBN,FBOLDPG,FBU,FBX S FBOLDPG=FBPAGE
- S FBI="",FBIOLD="",FBJ=""
- F S FBI=$O(^TMP($J,FBI)) Q:FBI="" D Q:FBABORT
- . F S FBJ=$O(^TMP($J,FBI,FBJ)) Q:FBJ="" D Q:FBABORT
- . . D:FBLP+5>IOSL HDR Q:FBABORT
- . . I FBRT="S" D
- . . . I FBI=FBIOLD,FBPAGE'=FBOLDPG W !!,"Key: ",FBI,?35,"(continued)" S FBLP=FBLP+2
- . . . I FBI'=FBIOLD W !!,"Key: ",FBI S FBIOLD=FBI,FBLP=FBLP+2
- . . . S FBDA=$P(FBJ,U,2),FBN=$P(FBJ,U),FBX=$S(FBDA>0:$$GETDATA(FBDA),1:FBN)
- . . . W !?2,$P(FBX,U)_$S($P(FBX,U,5)'="":" (T)",1:""),?37,$P(FBX,U,2),?44,$P(FBX,U,3) S FBLP=FBLP+1
- . . . I $P(FBX,U,4)'="" W !?5,"Division(s): ",$P(FBX,U,4) S FBLP=FBLP+1
- . . . S FBOLDPG=FBPAGE
- . . I FBRT="U" D
- . . . I FBI=FBIOLD,FBPAGE'=FBOLDPG W !,$P(FBI,U),?35,"(continued)" S FBLP=FBLP+1
- . . . I FBI'=FBIOLD D
- . . . . S FBIOLD=FBI
- . . . . S FBDA=$P(FBI,U,2),FBN=$P(FBI,U),FBX=$S(FBDA>0:$$GETDATA(FBDA),1:"")
- . . . . W !,$P(FBX,U)_$S($P(FBX,U,5)'="":" (T)",1:""),?37,$P(FBX,U,2),?44,$P(FBX,U,3) S FBLP=FBLP+1
- . . . . I $P(FBX,U,4)'="" W !?5,"Division(s): ",$P(FBX,U,4) S FBLP=FBLP+1
- . . . W !?3,"Key: ",FBJ S FBLP=FBLP+1
- . . . S FBOLDPG=FBPAGE
- I 'FBABORT,$E(IOST,1,2)="C-" N DIR S DIR(0)="E" D ^DIR
- D ^%ZISC
- END ;
- S:$D(ZTQUEUED) ZTREQ="@"
- K ^TMP($J),FBKEY,FBUSER,FBRT,FBACTIVE
- Q
- TERM(FBIEN) ;Extrinsic function that returns
- ; '1' if user is terminated, or
- ; '0' if not terminated.
- ;Input FBIEN is the IEN of the person in the New Person file (#200)
- N FBTERMDT,FBERR,FBRESULT S FBRESULT=0
- S FBTERMDT=$$GET1^DIQ(200,FBIEN_",",9.2,"","","FBERR")
- I FBTERMDT'="",FBTERMDT'>DT S FBRESULT=1
- Q FBRESULT
- ;
- HDR ;Writing report heading
- I $E(IOST,1,2)="C-",FBPAGE>0 D Q:FBABORT
- . N DIR S DIR(0)="E" D ^DIR
- . S:$D(DIRUT) FBABORT=1
- S FBPAGE=FBPAGE+1
- W @IOF,"Security Key Report for Fee Basis",?44,FBDTR," page ",FBPAGE
- I FBRT="S" W !?2,"by Security Key for ",$S(FBKEY=1:"all",1:"specified")," FB keys"
- I FBRT="U" W !?2,"by User for ",$S(FBUSER=1:"all",1:"specified")," users"
- W:'FBACTIVE " including terminated (T) users"
- W !!,"Name",?37,"SSN",?44,"Title",!,$E(FBLINE,1,35),?37,$E(FBLINE,1,4),?44,$E(FBLINE,1,30)
- S FBLP=5
- Q
- ;
- GETDATA(FBIEN) ;This extrinsic function returns a caret delimited string
- ;of Name^Last4_SSN^Title^Division(comma-delimited station #s)^Terminated_flag
- ;FBIEN is the IEN of the person in the New Person file (#200)
- N FBARRAY,FBERR,FBI,FBW,FBX,FBY
- S FBIEN=FBIEN_","
- D GETS^DIQ(200,FBIEN,".01;8;9","","FBARRAY","FBERR")
- S FBY=FBARRAY(200,FBIEN,9)
- S FBX=FBARRAY(200,FBIEN,.01)_"^"_$E(FBY,$L(FBY)-3,$L(FBY))_"^"_FBARRAY(200,FBIEN,8)
- K FBARRAY,FBERR D GETS^DIQ(200,FBIEN,"16*","I","FBARRAY","FBERR")
- S FBY="",FBI="",FBW=""
- F S FBI=$O(FBARRAY(200.02,FBI)) Q:FBI="" D
- . S FBW=FBARRAY(200.02,FBI,.01,"I") K FBERR
- . S FBW=$$GET1^DIQ(4,FBW_",",99,"","","FBERR")
- . S:FBW'="" FBY=FBY_$S(FBY="":"",1:", ")_FBW
- S FBX=FBX_"^"_FBY_"^"_$S($$TERM(FBIEN):"T",1:"")
- Q FBX
- ;FBAASKR
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAASKR 6274 printed Mar 13, 2025@21:01:21 Page 2
- FBAASKR ;WIOFO/LKG - SECURITY KEY REPORT ;1/29/15 11:27
- +1 ;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ; IAs
- +4 ; #1340 Lookup Security Key file (#19.1) entries
- +5 ; #4398 FIRST^VAUTOMA
- +6 ; #10060 New Person File (#200) Read w/FileMan
- +7 ; #10090 Institution File (#4) Read w/FileMan
- +8 ; #10076 ^XUSEC GLOBAL
- +9 ;
- ST ;
- +1 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y,FBABORT,FBACTIVE,FBRT,POP,VAUTSTR,VAUTNI,VAUTVB,FBKEY,FBUSER
- +2 SET DIR(0)="YB"
- SET DIR("A")="Should report include terminated users with keys"
- SET DIR("B")="NO"
- +3 DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- +4 SET FBACTIVE=$SELECT('Y:1,1:0)
- KILL DIR
- +5 SET FBABORT=0
- +6 SET DIR(0)="SB^S:SECURITY KEY;U:USER"
- SET DIR("A")="Sort by Security Key or User"
- +7 SET DIR("?",1)="Enter 'S' to have report by Security Key or"
- +8 SET DIR("?")=" 'U' to have the report by User. Enter '^' to exit."
- +9 SET DIR("??")="^D EN^DDIOL(""The report is users listed by Security Key (S) or Keys listed by User (U)."","""",""!?2"")"
- +10 DO ^DIR
- +11 if $DATA(DIRUT)
- GOTO END
- +12 SET FBRT=Y
- +13 IF FBRT="S"
- Begin DoDot:1
- +14 NEW DIC
- SET DIC="^DIC(19.1,"
- SET DIC("S")="I $E($P($G(^(0)),U),1,2)=""FB"",$E($P($G(^(0)),U),3)'=""Z"""
- +15 SET VAUTSTR="Fee Basis Security Key"
- SET VAUTNI=2
- SET VAUTVB="FBKEY"
- +16 DO FIRST^VAUTOMA
- IF Y=-1
- SET FBABORT=1
- +17 IF FBKEY=1
- Begin DoDot:2
- +18 NEW FBARR,FBERR,FBI
- +19 DO LIST^DIC(19.1,"","","","","","FB","B","I $E($P($G(^(0)),U),1,3)'=""FBZ""","","FBARR","FBERR")
- +20 FOR FBI=1:1:(+FBARR("DILIST",0))
- SET FBKEY(FBARR("DILIST",2,FBI))=FBARR("DILIST",1,FBI)
- End DoDot:2
- End DoDot:1
- if FBABORT
- GOTO END
- GOTO DEV
- +21 IF FBRT="U"
- Begin DoDot:1
- +22 NEW DIC
- SET DIC="^VA(200,"
- SET VAUTSTR="User"
- SET VAUTNI=2
- SET VAUTVB="FBUSER"
- +23 if FBACTIVE
- SET DIC("S")="I '$$TERM^FBAASKR(Y)"
- +24 DO FIRST^VAUTOMA
- IF Y=-1
- SET FBABORT=1
- End DoDot:1
- if FBABORT
- GOTO END
- GOTO DEV
- DEV ;Ask device
- +1 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- GOTO END
- +2 IF $DATA(IO("Q"))
- Begin DoDot:1
- +3 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
- +4 SET ZTRTN="COMPILE^FBAASKR"
- SET ZTDESC="Security Key Report for Fee Basis"
- +5 SET ZTSAVE("FBKEY")=""
- SET ZTSAVE("FBKEY(")=""
- SET ZTSAVE("FBUSER")=""
- SET ZTSAVE("FBUSER(")=""
- SET ZTSAVE("FBRT")=""
- SET ZTSAVE("FBACTIVE")=""
- +6 DO ^%ZTLOAD
- DO HOME^%ZIS
- End DoDot:1
- GOTO END
- COMPILE ;
- +1 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,FBABORT,FBDTR,FBLINE,FBLP,FBPAGE,X,Y
- +2 SET FBABORT=0
- SET $PIECE(FBLINE,"-",41)=""
- SET FBPAGE=0
- +3 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET FBDTR=Y
- +4 ;
- +5 KILL ^TMP($JOB)
- +6 IF FBRT="S"
- Begin DoDot:1
- +7 NEW FBERR,FBI,FBJ,FBK,FBN
- SET FBI=""
- +8 FOR
- SET FBI=$ORDER(FBKEY(FBI))
- if 'FBI
- QUIT
- Begin DoDot:2
- +9 SET FBJ=FBKEY(FBI)
- +10 IF '$DATA(^XUSEC(FBJ))
- SET ^TMP($JOB,FBJ,"No holders^0")=""
- QUIT
- +11 SET FBK=""
- +12 FOR
- SET FBK=$ORDER(^XUSEC(FBJ,FBK))
- if FBK=""
- QUIT
- Begin DoDot:3
- +13 IF FBACTIVE
- IF $$TERM(FBK)
- QUIT
- +14 SET FBN=$$GET1^DIQ(200,FBK_",",.01,"","","FBERR")
- KILL FBERR
- +15 SET ^TMP($JOB,FBJ,FBN_"^"_FBK)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 IF FBRT="U"
- Begin DoDot:1
- +17 IF FBUSER'=1
- Begin DoDot:2
- +18 NEW FBC,FBK,FBJ
- SET FBK=""
- +19 FOR
- SET FBK=$ORDER(FBUSER(FBK))
- if FBK=""
- QUIT
- Begin DoDot:3
- +20 SET FBJ="FA~"
- SET FBC=0
- +21 FOR
- SET FBJ=$ORDER(^XUSEC(FBJ))
- if FBJ]"FBY~"!(FBJ="")
- QUIT
- Begin DoDot:4
- +22 IF $DATA(^XUSEC(FBJ,FBK))
- SET ^TMP($JOB,FBUSER(FBK)_"^"_FBK,FBJ)=""
- SET FBC=FBC+1
- End DoDot:4
- +23 if FBC=0
- SET ^TMP($JOB,FBUSER(FBK)_"^"_FBK,"No Fee Basis Key Held")=""
- End DoDot:3
- End DoDot:2
- QUIT
- +24 IF FBUSER=1
- Begin DoDot:2
- +25 NEW FBERR,FBJ,FBK,FBN
- +26 SET FBJ="FA~"
- +27 FOR
- SET FBJ=$ORDER(^XUSEC(FBJ))
- if FBJ]"FBY~"!(FBJ="")
- QUIT
- Begin DoDot:3
- +28 SET FBK=0
- +29 FOR
- SET FBK=$ORDER(^XUSEC(FBJ,FBK))
- if FBK=""
- QUIT
- Begin DoDot:4
- +30 IF FBACTIVE
- IF $$TERM(FBK)
- QUIT
- +31 SET FBN=$$GET1^DIQ(200,FBK_",",".01","","","FBERR")
- KILL FBERR
- +32 SET ^TMP($JOB,FBN_"^"_FBK,FBJ)=""
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +33 ;
- PRT ;Print report
- +1 USE IO
- DO HDR
- +2 NEW FBI,FBIOLD,FBDA,FBJ,FBK,FBN,FBOLDPG,FBU,FBX
- SET FBOLDPG=FBPAGE
- +3 SET FBI=""
- SET FBIOLD=""
- SET FBJ=""
- +4 FOR
- SET FBI=$ORDER(^TMP($JOB,FBI))
- if FBI=""
- QUIT
- Begin DoDot:1
- +5 FOR
- SET FBJ=$ORDER(^TMP($JOB,FBI,FBJ))
- if FBJ=""
- QUIT
- Begin DoDot:2
- +6 if FBLP+5>IOSL
- DO HDR
- if FBABORT
- QUIT
- +7 IF FBRT="S"
- Begin DoDot:3
- +8 IF FBI=FBIOLD
- IF FBPAGE'=FBOLDPG
- WRITE !!,"Key: ",FBI,?35,"(continued)"
- SET FBLP=FBLP+2
- +9 IF FBI'=FBIOLD
- WRITE !!,"Key: ",FBI
- SET FBIOLD=FBI
- SET FBLP=FBLP+2
- +10 SET FBDA=$PIECE(FBJ,U,2)
- SET FBN=$PIECE(FBJ,U)
- SET FBX=$SELECT(FBDA>0:$$GETDATA(FBDA),1:FBN)
- +11 WRITE !?2,$PIECE(FBX,U)_$SELECT($PIECE(FBX,U,5)'="":" (T)",1:""),?37,$PIECE(FBX,U,2),?44,$PIECE(FBX,U,3)
- SET FBLP=FBLP+1
- +12 IF $PIECE(FBX,U,4)'=""
- WRITE !?5,"Division(s): ",$PIECE(FBX,U,4)
- SET FBLP=FBLP+1
- +13 SET FBOLDPG=FBPAGE
- End DoDot:3
- +14 IF FBRT="U"
- Begin DoDot:3
- +15 IF FBI=FBIOLD
- IF FBPAGE'=FBOLDPG
- WRITE !,$PIECE(FBI,U),?35,"(continued)"
- SET FBLP=FBLP+1
- +16 IF FBI'=FBIOLD
- Begin DoDot:4
- +17 SET FBIOLD=FBI
- +18 SET FBDA=$PIECE(FBI,U,2)
- SET FBN=$PIECE(FBI,U)
- SET FBX=$SELECT(FBDA>0:$$GETDATA(FBDA),1:"")
- +19 WRITE !,$PIECE(FBX,U)_$SELECT($PIECE(FBX,U,5)'="":" (T)",1:""),?37,$PIECE(FBX,U,2),?44,$PIECE(FBX,U,3)
- SET FBLP=FBLP+1
- +20 IF $PIECE(FBX,U,4)'=""
- WRITE !?5,"Division(s): ",$PIECE(FBX,U,4)
- SET FBLP=FBLP+1
- End DoDot:4
- +21 WRITE !?3,"Key: ",FBJ
- SET FBLP=FBLP+1
- +22 SET FBOLDPG=FBPAGE
- End DoDot:3
- End DoDot:2
- if FBABORT
- QUIT
- End DoDot:1
- if FBABORT
- QUIT
- +23 IF 'FBABORT
- IF $EXTRACT(IOST,1,2)="C-"
- NEW DIR
- SET DIR(0)="E"
- DO ^DIR
- +24 DO ^%ZISC
- END ;
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 KILL ^TMP($JOB),FBKEY,FBUSER,FBRT,FBACTIVE
- +3 QUIT
- TERM(FBIEN) ;Extrinsic function that returns
- +1 ; '1' if user is terminated, or
- +2 ; '0' if not terminated.
- +3 ;Input FBIEN is the IEN of the person in the New Person file (#200)
- +4 NEW FBTERMDT,FBERR,FBRESULT
- SET FBRESULT=0
- +5 SET FBTERMDT=$$GET1^DIQ(200,FBIEN_",",9.2,"","","FBERR")
- +6 IF FBTERMDT'=""
- IF FBTERMDT'>DT
- SET FBRESULT=1
- +7 QUIT FBRESULT
- +8 ;
- HDR ;Writing report heading
- +1 IF $EXTRACT(IOST,1,2)="C-"
- IF FBPAGE>0
- Begin DoDot:1
- +2 NEW DIR
- SET DIR(0)="E"
- DO ^DIR
- +3 if $DATA(DIRUT)
- SET FBABORT=1
- End DoDot:1
- if FBABORT
- QUIT
- +4 SET FBPAGE=FBPAGE+1
- +5 WRITE @IOF,"Security Key Report for Fee Basis",?44,FBDTR," page ",FBPAGE
- +6 IF FBRT="S"
- WRITE !?2,"by Security Key for ",$SELECT(FBKEY=1:"all",1:"specified")," FB keys"
- +7 IF FBRT="U"
- WRITE !?2,"by User for ",$SELECT(FBUSER=1:"all",1:"specified")," users"
- +8 if 'FBACTIVE
- WRITE " including terminated (T) users"
- +9 WRITE !!,"Name",?37,"SSN",?44,"Title",!,$EXTRACT(FBLINE,1,35),?37,$EXTRACT(FBLINE,1,4),?44,$EXTRACT(FBLINE,1,30)
- +10 SET FBLP=5
- +11 QUIT
- +12 ;
- GETDATA(FBIEN) ;This extrinsic function returns a caret delimited string
- +1 ;of Name^Last4_SSN^Title^Division(comma-delimited station #s)^Terminated_flag
- +2 ;FBIEN is the IEN of the person in the New Person file (#200)
- +3 NEW FBARRAY,FBERR,FBI,FBW,FBX,FBY
- +4 SET FBIEN=FBIEN_","
- +5 DO GETS^DIQ(200,FBIEN,".01;8;9","","FBARRAY","FBERR")
- +6 SET FBY=FBARRAY(200,FBIEN,9)
- +7 SET FBX=FBARRAY(200,FBIEN,.01)_"^"_$EXTRACT(FBY,$LENGTH(FBY)-3,$LENGTH(FBY))_"^"_FBARRAY(200,FBIEN,8)
- +8 KILL FBARRAY,FBERR
- DO GETS^DIQ(200,FBIEN,"16*","I","FBARRAY","FBERR")
- +9 SET FBY=""
- SET FBI=""
- SET FBW=""
- +10 FOR
- SET FBI=$ORDER(FBARRAY(200.02,FBI))
- if FBI=""
- QUIT
- Begin DoDot:1
- +11 SET FBW=FBARRAY(200.02,FBI,.01,"I")
- KILL FBERR
- +12 SET FBW=$$GET1^DIQ(4,FBW_",",99,"","","FBERR")
- +13 if FBW'=""
- SET FBY=FBY_$SELECT(FBY="":"",1:", ")_FBW
- End DoDot:1
- +14 SET FBX=FBX_"^"_FBY_"^"_$SELECT($$TERM(FBIEN):"T",1:"")
- +15 QUIT FBX
- +16 ;FBAASKR
