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 Sep 23, 2025@19:32:43 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
