FBAAIAU ;ALB/FA - BUILD C8 MESSAGE ;03 Dec 2013 9:34 AM
;;3.5;FEE BASIS;**123**;JAN 30, 1995;Build 51
;;Per VA Directive 6402, this routine should not be modified.
;
; Contains utility functions for IPAC Vendor Agreement Management
;
;-----------------------------------------------------------------------------
; Methods
; CHKREQ - Makes sure that all the required fields of the IPAC Vendor
; agreement have values and if they do, changes the status of
; the agreement to 'A'
; DELALL - Delete all Vendor Agreements (161.95) and MRAs (161.96)
; LOCKVA - Attempts to lock a specified IPAC Vendor Agreement
; SELMRA - Displays a list of all the current MRA records and allows the
; user to select one
; SELVA - Displays a list of all the current IPAC Vendor Agreements and
; allows the user to either select one to be edited or type 'NEW'
; to enter a new one
; VADISP - Returns the IPAC Vendor Agreement Display Layout for a
; specified vendor agreement
; VALOAD - Returns an array of external field values for a specified
; Vendor Agreement
; UNLOCKVA - Unlocks a specified IPAC Vendor Agreement
;-----------------------------------------------------------------------------
;
CHKREQ(VAIEN) ;EP
; Checks to see if all of the required fields of the IPAC vendor agreement have
; been entered and if so, change the status of the agreement to 'A'
; Input: VAIEN - IEN of the IPAC Vendor agreement to be checked
; Called From: FBAAIAE, FBAAIAC
; NOTE: Quits if the current status of the agreement is not 'N' without
; doing anything. Also, the fields of the Vendor agreement are
; HARD CODED in this method - if a new required field is added this
; method must be modified
N ARR,ERR,DA,DIE,DR,DTOUT,FLD,FLDINFO,NDE,PCE,STOP
Q:'$D(^FBAA(161.95,VAIEN,0)) ; Invalid IPAC agreement IEN
Q:$P(^FBAA(161.95,VAIEN,0),U,4)'="N" ; Status isn't 'N'
;
; First get a list of all the required fields
F FLD=1:1:16,7.5 D ; NOTE: HARD CODED field list
. D FIELD^DID(161.95,FLD,,"GLOBAL SUBSCRIPT LOCATION;SPECIFIER","ARR","ERR")
. Q:$E(ARR("SPECIFIER"),1)'="R" ; Not a required field
. S FLDINFO(FLD)=ARR("GLOBAL SUBSCRIPT LOCATION") ; Node;Piece
;
; Now loop Through all of the required fields and check for data
S FLD=0,STOP=0
F D Q:FLD="" Q:STOP
. S FLD=$O(FLDINFO(FLD))
. Q:FLD=""
. S NDE=$P(FLDINFO(FLD),";",1),PCE=$P(FLDINFO(FLD),";",2)
. S:$P($G(^FBAA(161.95,VAIEN,NDE)),U,PCE)="" STOP=1 ; Missing required field
Q:STOP
;
S DIE=161.95,DA=VAIEN
S DR="3////A"
D ^DIE
Q
;
DELALL ;EP
; Clean-up utility to delete all existing Vendor agreements and MRA records
; Input: None
; Output: ^FBAA(161.95) AND ^FBAA(161.96) are cleared
N DA,DIE,DIK,DR,DTOUT
S DIK="^FBAA(161.95,"
S DA=0
F D Q:DA=""
. S DA=$O(^FBAA(161.95,DA))
. Q:DA=""
. D ^DIK
;
S DIK="^FBAA(161.96,"
S DA=0
F D Q:DA=""
. S DA=$O(^FBAA(161.96,DA))
. Q:DA=""
. D ^DIK
;
; Reset the Last IPAC number
S DIE=161.4,DA=1,DR="80///100"
D ^DIE ; File the new last number
Q
;
SELVA(FLINE,STEXT,NEW,SVENIEN) ;EP
; Displays all of the currently filed IPAC Vendor agreements and allows the user
; to select one to edit or type 'NEW' to enter a new one
; Input: FLINE - Text of the first line to be displayed
; STEXT - User Selection prompt to be displayed
; NOTE: "" is allowed here. If null, this becomes a
; display only method with no ability select a Vendor
; OR to type NEW to enter a new one
; NEW - 1 to allow NEW as a valid selection, 0 otherwise
; SVENIEN - IEN of a specified vendor
; Optional, if specified, only IPAC agreements for the
; specified vendor will be displayed
; Output: Current IPAC Vendor agreements displayed to the screen, if there are none,
; a message is displayed
; Returns: VAIEN - IEN of the selected IPAC Agreement
; 0 - User wants/needs to enter a new agreement
; "" - No IPAC Vendor Agreement was selected
N CNT,LN,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IX,OUT,VADATA,VAIEN,VENIEN,X,XX,Y
S:'$D(SVENIEN) SVENIEN=""
;
; First create and array of all current IPAC Vendor Agreement data to display
S CNT=0,VAIEN=0
F D Q:+VAIEN=0
. S VAIEN=$O(^FBAA(161.95,VAIEN))
. Q:+VAIEN=0
. S VENIEN=$P(^FBAA(161.95,VAIEN,0),U,2) ; Vendor IEN
. Q:(SVENIEN'="")&(SVENIEN'=VENIEN) ; Not the selected Vendor
. S CNT=CNT+1
. S XX=$$LJ^XLFSTR(CNT,3) ; Selection #
. S XX=XX_$$LJ^XLFSTR($P(^FBAA(161.95,VAIEN,0),U,1),11) ; ID
. S XX=XX_$$LJ^XLFSTR($P(^FBAA(161.95,VAIEN,0),U,3),5) ; Fiscal Year
. S XX=XX_$$LJ^XLFSTR($$GET1^DIQ(161.2,VENIEN_",",.01),"29T") ; Vendor Name
. S XX=XX_" "
. S XX=XX_$P(^FBAA(161.95,VAIEN,0),U,4)_" " ; Status
. S XX=XX_$$LJ^XLFSTR($P(^FBAA(161.95,VAIEN,0),U,5),"26T") ; Description
. S VADATA(CNT)=VAIEN_U_XX
;
I 'CNT D Q OUT
. S OUT=""
. Q:STEXT=""
. W !!,"No IPAC Agreements are currently on file."
. H:'NEW 1
. Q:'NEW
. S DIR("A")="Enter a new agreement"
. S DIR(0)="Y"
. D ^DIR
. S:+Y=1 OUT=0
;
; Next display all of the current IPAC Vendor Agreements
S DIR(0)="FO",LN=0
S:NEW DIR("B")="NEW"
S LN=LN+1,DIR("A",LN)=FLINE
S LN=LN+1,DIR("A",LN)=" "
S LN=LN+1,DIR("A",LN)="# ID FY Vendor S Description"
S LN=LN+1,DIR("A",LN)="-- ---------- ---- ------------------------------ - -------------------------"
S IX=""
F D Q:IX=""
. S IX=$O(VADATA(IX))
. Q:IX=""
. S LN=LN+1,DIR("A",LN)=$P(VADATA(IX),U,2)
I STEXT="" D Q "" ; Just display, no selection
. W !!
. S LN=""
. F D Q:LN=""
. . S LN=$O(DIR("A",LN))
. . Q:LN=""
. . W !,DIR("A",LN)
S LN=LN+1,DIR("A",LN)=" "
S LN=LN+1,DIR("A",LN)=STEXT
S DIR("A")="Selection #"
SELVA1 ; Looping tag
W !!
K X,Y
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q "" ; User timed out or pressed ^
S XX=$$UP^XLFSTR(Y)
I NEW Q:(XX="NEW")!(XX="N")!(XX="NE")!(XX="") 0 ; Creating a new one
I 'NEW Q:XX="" "" ; User quitting
I XX>0,XX'>CNT,XX?.N Q $P(VADATA(XX),U,1) ; Selected IEN
;
W !!,*7,"Enter a number from 1-"_CNT
W:NEW " or Type 'NEW'"
H 1
G SELVA1
;
SELMRA(FLINE,STEXT,STATUS,ACTION) ;EP
; Displays all of the currently filed MRA records with a status of 'T' and
; allows the user to select one
; Input: FLINE - Text of the first line to be displayed
; STEXT - User Selection prompt to be displayed
; STATUS - 'P' - Display pending MRA Records
; 'T' - Display transmitted MRA records
; '' - Display both pending and transmitted records
; ACTION - 'A' - Display Add MRA records
; 'C' - Display Change MRA records
; 'D' - Display Deleted MRA records
; '' - Display MRA records with any type of action
; Output: MRA Records that match the specified criteria are displayed to the screen.
; If there are none, a message is displayed
; Returns: MRAIEN - IEN of the selected MRA Record
; "" - No MRA record was selected
N CNT,LN,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IX,MRAACT,MRADATA,MRAIEN,MRASTAT
N OUT,TDT,VAIEN,VENIEN,X,XX,Y,ZZ
;
; First create and array of all current MRA records that match the selection criteria
S CNT=0,MRAIEN=0
F D Q:+MRAIEN=0
. S MRAIEN=$O(^FBAA(161.96,MRAIEN))
. Q:+MRAIEN=0
. S ZZ=^FBAA(161.96,MRAIEN,0)
. S MRAACT=$P(ZZ,U,4) ; Action of the MRA Record
. S MRASTAT=$P(ZZ,U,5) ; Status of the MRA Record
. I STATUS'="",STATUS'=MRASTAT Q ; Not the specified status
. I ACTION'="",ACTION'=MRAACT Q ; Not the specified action
. S CNT=CNT+1
. S XX=$$LJ^XLFSTR(CNT,3) ; Selection #
. S XX=XX_$$LJ^XLFSTR($P(ZZ,U,3),11) ; IPAC Agreement ID
. S XX=XX_$$LJ^XLFSTR(MRASTAT,2) ; Status
. S XX=XX_$$LJ^XLFSTR(MRAACT,2) ; Action
. I (STATUS="")!(STATUS="T") D ; Transmit Date
. . S TDT=$P(ZZ,U,6)
. . S:TDT'="" TDT=$$FMTE^XLFDT(TDT,2) ; Converted to external
. . S XX=XX_$$LJ^XLFSTR(TDT,9)
. ;
. ; Only displaying MRA records with an action of DELETE - no more columns to display
. I ACTION="D" S MRADATA(CNT)=MRAIEN_U_XX Q
. S VAIEN=$P(ZZ,U,2) ; IPAC Agreement IEN
. S VENIEN=$P($G(^FBAA(161.95,VAIEN,0)),U,2) ; Vendor IEN
. S XX=XX_$$LJ^XLFSTR($$GET1^DIQ(161.2,VENIEN_",",.01),"30T")_" " ; Vendor Name
. S XX=XX_$$LJ^XLFSTR($P(^FBAA(161.95,VAIEN,0),U,5),"23T") ; Description
. S MRADATA(CNT)=MRAIEN_U_XX
;
I 'CNT D Q OUT
. S OUT=""
. Q:STEXT=""
. W !!,"No MRA records that match the specified criteria are currently on file."
;
; Next display all of the found MRA Records
S DIR(0)="FO",LN=0
S LN=LN+1,DIR("A",LN)=FLINE
S LN=LN+1,DIR("A",LN)=" "
S LN=LN+1,DIR("A",LN)="# ID A "
I (STATUS="")!(STATUS="T") D
. S DIR("A",LN)=DIR("A",LN)_"S Trans Dt "
I (ACTION'="D") D
. S DIR("A",LN)=DIR("A",LN)_"Vendor Description"
S LN=LN+1,DIR("A",LN)="-- ---------- - "
I (STATUS="")!(STATUS="T") D
. S DIR("A",LN)=DIR("A",LN)_"- -------- "
I (ACTION'="D") D
. S DIR("A",LN)=DIR("A",LN)_"------------------------------ ----------------------"
S IX=""
F D Q:IX=""
. S IX=$O(MRADATA(IX))
. Q:IX=""
. S LN=LN+1,DIR("A",LN)=$P(MRADATA(IX),U,2)
S LN=LN+1,DIR("A",LN)=" "
S LN=LN+1,DIR("A",LN)=STEXT
S DIR("A")="Selection #"
SELMRA1 ; Looping tag
W !!
K X,Y
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q "" ; User timed out or pressed ^
S XX=$$UP^XLFSTR(Y)
Q:XX="" "" ; User quitting
I XX>0,XX'>CNT,XX?.N Q $P(MRADATA(XX),U,1) ; Selected IEN
;
W !!,*7,"Enter a number from 1-"_CNT
H 1
G SELMRA1
;
VADISP(VAIEN,TOSCREEN,VAOUT) ;EP
; Returns the IPAC Vendor Agreement Display Layout for a specified vendor
; agreement
; Input: VAIEN - Vendor Agreement IEN to build display layout for
; TOSCREEN - 1 - Display the Vendor Agreement to the screen, don't return VAOUT
; 0 - Don't display it, return array VAOUT instead
; Output: VAOUT - Array of IPAC Vendor Agreement Display Layout lines
; Only returned if TOSCREEN=0
;
N LN,VADATA,XX
K VAOUT
; Invalid Vendor Agreement
Q:'$D(^FBAA(161.95,VAIEN))
;
D VALOAD(VAIEN,.VADATA)
S XX=VADATA("ID"),VAOUT(1)="IPAC Vendor Agreement ID: "_$$LJ^XLFSTR(XX,12)
S XX=VADATA("STAT"),VAOUT(1)=VAOUT(1)_"Status: "_$$LJ^XLFSTR(XX,10)
S XX=VADATA("FY"),VAOUT(1)=VAOUT(1)_"FY: "_$$LJ^XLFSTR(XX,1,6)
S XX=VADATA("VENDOR"),VAOUT(2)="Vendor: "_$$LJ^XLFSTR(XX,48)
S XX=VADATA("DESC"),VAOUT(3)=" Desc: "_$$LJ^XLFSTR(XX,62)
S XX=VADATA("SHAN"),VAOUT(4)=" Sharing Agreement #: "_$$LJ^XLFSTR(XX,"15T")
S XX=VADATA("CALC"),VAOUT(5)="Customer ALC: "_$$LJ^XLFSTR(XX,10)
S XX=VADATA("RTAS"),VAOUT(5)=VAOUT(5)_"Receiver TAS: "_$$LJ^XLFSTR(XX,"29T")
S XX=VADATA("STAS"),VAOUT(6)=$$LJ^XLFSTR("",24," ")_" Sender TAS: "_$$LJ^XLFSTR(XX,"29T")
S XX=VADATA("ASN"),VAOUT(7)="Agency Field Station #: "_$$LJ^XLFSTR(XX,"10T")
S XX=VADATA("OB"),VAOUT(7)=VAOUT(7)_"Obligating Document #: "_$$LJ^XLFSTR(XX,"19T")
S VAOUT(8)="Station Contact: "
S XX=VADATA("CON"),VAOUT(9)=" Name: "_$$LJ^XLFSTR(XX,62)
S XX=VADATA("CONPHN"),VAOUT(10)=" Phone: "_$$LJ^XLFSTR(XX,"17T")
S XX=VADATA("CONEM"),VAOUT(10)=VAOUT(10)_" Email: "_$$LJ^XLFSTR(XX,"40T") ; 1st 40 chars or email
S VAOUT(11)=$S($L(XX)'>40:"",1:" "_$E(XX,41,$L(XX))) ; Remaining chars of email
S VAOUT(12)="Complete Line of Accounting: "
S XX=VADATA("LOA"),VAOUT(13)=" "_$$LJ^XLFSTR(XX,62)
S VAOUT(14)="Description of Goods & Services: "
S XX=VADATA("GOOD"),VAOUT(15)=" "_$$LJ^XLFSTR(XX,"70T")
S VAOUT(16)=$S($L(XX)'>70:"",1:" "_$E(XX,71,140)) ; Next 70 chars
S VAOUT(17)=$S($L(XX)'>140:"",1:" "_$E(XX,141,$L(XX))) ; Remaining chars
S VAOUT(18)="Miscellaneous Info: "
S XX=VADATA("MISC1"),VAOUT(19)="1) "_$$LJ^XLFSTR(XX,"75T")
S VAOUT(20)=$S($L(XX)'>75:"",1:" "_$E(XX,76,150)) ; Next 75 chars
S VAOUT(21)=$S($L(XX)'>150:"",1:" "_$E(XX,151,$L(XX))) ; Remaining chars
S XX=VADATA("MISC2"),VAOUT(22)="2) "_$$LJ^XLFSTR(XX,"75T")
S VAOUT(23)=$S($L(XX)'>75:"",1:" "_$E(XX,76,$L(XX))) ; Remaining chars
Q:'TOSCREEN
;
S LN=""
F D Q:LN=""
. S LN=$O(VAOUT(LN))
. Q:LN=""
. I VAOUT(LN)="***" W ! Q
. W:$TR(VAOUT(LN)," ","")'="" !,VAOUT(LN)
K VAOUT
Q
;
VALOAD(VAIEN,VADATA) ;EP
; Returns an array of external field values for a specified Vendor Agreement
; Input: VAIEN - Vendor Agreement IEN
; Output: VADATA("ASN") - Agency Field Station Number
; VADATA("CALC") - Customer ALC
; VADATA("CON") - Station Contact Name
; VADATA("CONEM") - Station Contact Email
; VADATA("CONPHN")- Station Contact Phone
; VADATA("DESC") - Vendor Agreement Description
; VADATA("FY") - Fiscal Year
; VADATA("GOOD") - Description of Goods and Services
; VADATA("ID") - Vendor Agreement ID
; VADATA("LOA") - Complete line of Accounting
; VADATA("OB") - Obligating document number
; VADATA("MISC1") - Miscellaneous Info 1
; VADATA("MISC2") - Miscellaneous Info 2
; VADATA("RTAS") - Receiver TAS
; VADATA("SHAN") - Sharing Agreement Number
; VADATA("STAS") - Sender TAS
; VADATA("STAT") - Vendor Agreement Status
; VADATA("VENDOR")- External Vendor name
;
;
N IPAC
D GETS^DIQ(161.95,VAIEN_",","**","E","IPAC")
S VADATA("ID")=IPAC(161.95,VAIEN_",",".01","E")
;
S VADATA("VENDOR")=IPAC(161.95,VAIEN_",",1,"E")
S VADATA("FY")=IPAC(161.95,VAIEN_",",2,"E")
S VADATA("STAT")=IPAC(161.95,VAIEN_",",3,"E")
S VADATA("DESC")=IPAC(161.95,VAIEN_",",4,"E")
S VADATA("SHAN")=IPAC(161.95,VAIEN_",",5,"E")
S VADATA("CALC")=IPAC(161.95,VAIEN_",",6,"E")
S VADATA("RTAS")=IPAC(161.95,VAIEN_",",7,"E")
S VADATA("STAS")=IPAC(161.95,VAIEN_",",7.5,"E")
S VADATA("ASN")=IPAC(161.95,VAIEN_",",8,"E")
S VADATA("OB")=IPAC(161.95,VAIEN_",",9,"E")
S VADATA("CON")=IPAC(161.95,VAIEN_",",10,"E")
S VADATA("CONPHN")=IPAC(161.95,VAIEN_",",11,"E")
S VADATA("CONEM")=IPAC(161.95,VAIEN_",",12,"E")
S VADATA("LOA")=IPAC(161.95,VAIEN_",",13,"E")
S VADATA("GOOD")=IPAC(161.95,VAIEN_",",14,"E")
S VADATA("MISC1")=IPAC(161.95,VAIEN_",",15,"E")
S VADATA("MISC2")=IPAC(161.95,VAIEN_",",16,"E")
Q
;
LOCKVA(VAIEN,DMSG) ;EP
; Attempt to lock IPAC Vendor Agreement
; Input: VAIEN - IPAC Vendor Agreement to be locked
; DMSG - 1 - Display locked message
; 0 - Don't display locked message
; Optional, defaults to 1
; Returns: 1 - IPAC Vendor Agreement locked, 0 otherwise
;
S:'$D(DMSG) DMSG=1
L +^FBAA(161.95,VAIEN):0
I '$T D Q 0
. W:DMSG !!,"Somebody is already editing this agreement. Try again later."
. H 1
Q 1
;
UNLOCKVA(VAIEN) ;EP
; Unlock the IPAC Vendor Agreement
; Input: VAIEN - Vendor Agreement to be locked
; Output: IPAC Vendor Agreement is unlocked
L -^FBAA(161.95,VAIEN)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAIAU 16577 printed Sep 23, 2025@19:31:46 Page 2
FBAAIAU ;ALB/FA - BUILD C8 MESSAGE ;03 Dec 2013 9:34 AM
+1 ;;3.5;FEE BASIS;**123**;JAN 30, 1995;Build 51
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Contains utility functions for IPAC Vendor Agreement Management
+5 ;
+6 ;-----------------------------------------------------------------------------
+7 ; Methods
+8 ; CHKREQ - Makes sure that all the required fields of the IPAC Vendor
+9 ; agreement have values and if they do, changes the status of
+10 ; the agreement to 'A'
+11 ; DELALL - Delete all Vendor Agreements (161.95) and MRAs (161.96)
+12 ; LOCKVA - Attempts to lock a specified IPAC Vendor Agreement
+13 ; SELMRA - Displays a list of all the current MRA records and allows the
+14 ; user to select one
+15 ; SELVA - Displays a list of all the current IPAC Vendor Agreements and
+16 ; allows the user to either select one to be edited or type 'NEW'
+17 ; to enter a new one
+18 ; VADISP - Returns the IPAC Vendor Agreement Display Layout for a
+19 ; specified vendor agreement
+20 ; VALOAD - Returns an array of external field values for a specified
+21 ; Vendor Agreement
+22 ; UNLOCKVA - Unlocks a specified IPAC Vendor Agreement
+23 ;-----------------------------------------------------------------------------
+24 ;
CHKREQ(VAIEN) ;EP
+1 ; Checks to see if all of the required fields of the IPAC vendor agreement have
+2 ; been entered and if so, change the status of the agreement to 'A'
+3 ; Input: VAIEN - IEN of the IPAC Vendor agreement to be checked
+4 ; Called From: FBAAIAE, FBAAIAC
+5 ; NOTE: Quits if the current status of the agreement is not 'N' without
+6 ; doing anything. Also, the fields of the Vendor agreement are
+7 ; HARD CODED in this method - if a new required field is added this
+8 ; method must be modified
+9 NEW ARR,ERR,DA,DIE,DR,DTOUT,FLD,FLDINFO,NDE,PCE,STOP
+10 ; Invalid IPAC agreement IEN
if '$DATA(^FBAA(161.95,VAIEN,0))
QUIT
+11 ; Status isn't 'N'
if $PIECE(^FBAA(161.95,VAIEN,0),U,4)'="N"
QUIT
+12 ;
+13 ; First get a list of all the required fields
+14 ; NOTE: HARD CODED field list
FOR FLD=1:1:16,7.5
Begin DoDot:1
+15 DO FIELD^DID(161.95,FLD,,"GLOBAL SUBSCRIPT LOCATION;SPECIFIER","ARR","ERR")
+16 ; Not a required field
if $EXTRACT(ARR("SPECIFIER"),1)'="R"
QUIT
+17 ; Node;Piece
SET FLDINFO(FLD)=ARR("GLOBAL SUBSCRIPT LOCATION")
End DoDot:1
+18 ;
+19 ; Now loop Through all of the required fields and check for data
+20 SET FLD=0
SET STOP=0
+21 FOR
Begin DoDot:1
+22 SET FLD=$ORDER(FLDINFO(FLD))
+23 if FLD=""
QUIT
+24 SET NDE=$PIECE(FLDINFO(FLD),";",1)
SET PCE=$PIECE(FLDINFO(FLD),";",2)
+25 ; Missing required field
if $PIECE($GET(^FBAA(161.95,VAIEN,NDE)),U,PCE)=""
SET STOP=1
End DoDot:1
if FLD=""
QUIT
if STOP
QUIT
+26 if STOP
QUIT
+27 ;
+28 SET DIE=161.95
SET DA=VAIEN
+29 SET DR="3////A"
+30 DO ^DIE
+31 QUIT
+32 ;
DELALL ;EP
+1 ; Clean-up utility to delete all existing Vendor agreements and MRA records
+2 ; Input: None
+3 ; Output: ^FBAA(161.95) AND ^FBAA(161.96) are cleared
+4 NEW DA,DIE,DIK,DR,DTOUT
+5 SET DIK="^FBAA(161.95,"
+6 SET DA=0
+7 FOR
Begin DoDot:1
+8 SET DA=$ORDER(^FBAA(161.95,DA))
+9 if DA=""
QUIT
+10 DO ^DIK
End DoDot:1
if DA=""
QUIT
+11 ;
+12 SET DIK="^FBAA(161.96,"
+13 SET DA=0
+14 FOR
Begin DoDot:1
+15 SET DA=$ORDER(^FBAA(161.96,DA))
+16 if DA=""
QUIT
+17 DO ^DIK
End DoDot:1
if DA=""
QUIT
+18 ;
+19 ; Reset the Last IPAC number
+20 SET DIE=161.4
SET DA=1
SET DR="80///100"
+21 ; File the new last number
DO ^DIE
+22 QUIT
+23 ;
SELVA(FLINE,STEXT,NEW,SVENIEN) ;EP
+1 ; Displays all of the currently filed IPAC Vendor agreements and allows the user
+2 ; to select one to edit or type 'NEW' to enter a new one
+3 ; Input: FLINE - Text of the first line to be displayed
+4 ; STEXT - User Selection prompt to be displayed
+5 ; NOTE: "" is allowed here. If null, this becomes a
+6 ; display only method with no ability select a Vendor
+7 ; OR to type NEW to enter a new one
+8 ; NEW - 1 to allow NEW as a valid selection, 0 otherwise
+9 ; SVENIEN - IEN of a specified vendor
+10 ; Optional, if specified, only IPAC agreements for the
+11 ; specified vendor will be displayed
+12 ; Output: Current IPAC Vendor agreements displayed to the screen, if there are none,
+13 ; a message is displayed
+14 ; Returns: VAIEN - IEN of the selected IPAC Agreement
+15 ; 0 - User wants/needs to enter a new agreement
+16 ; "" - No IPAC Vendor Agreement was selected
+17 NEW CNT,LN,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IX,OUT,VADATA,VAIEN,VENIEN,X,XX,Y
+18 if '$DATA(SVENIEN)
SET SVENIEN=""
+19 ;
+20 ; First create and array of all current IPAC Vendor Agreement data to display
+21 SET CNT=0
SET VAIEN=0
+22 FOR
Begin DoDot:1
+23 SET VAIEN=$ORDER(^FBAA(161.95,VAIEN))
+24 if +VAIEN=0
QUIT
+25 ; Vendor IEN
SET VENIEN=$PIECE(^FBAA(161.95,VAIEN,0),U,2)
+26 ; Not the selected Vendor
if (SVENIEN'="")&(SVENIEN'=VENIEN)
QUIT
+27 SET CNT=CNT+1
+28 ; Selection #
SET XX=$$LJ^XLFSTR(CNT,3)
+29 ; ID
SET XX=XX_$$LJ^XLFSTR($PIECE(^FBAA(161.95,VAIEN,0),U,1),11)
+30 ; Fiscal Year
SET XX=XX_$$LJ^XLFSTR($PIECE(^FBAA(161.95,VAIEN,0),U,3),5)
+31 ; Vendor Name
SET XX=XX_$$LJ^XLFSTR($$GET1^DIQ(161.2,VENIEN_",",.01),"29T")
+32 SET XX=XX_" "
+33 ; Status
SET XX=XX_$PIECE(^FBAA(161.95,VAIEN,0),U,4)_" "
+34 ; Description
SET XX=XX_$$LJ^XLFSTR($PIECE(^FBAA(161.95,VAIEN,0),U,5),"26T")
+35 SET VADATA(CNT)=VAIEN_U_XX
End DoDot:1
if +VAIEN=0
QUIT
+36 ;
+37 IF 'CNT
Begin DoDot:1
+38 SET OUT=""
+39 if STEXT=""
QUIT
+40 WRITE !!,"No IPAC Agreements are currently on file."
+41 if 'NEW
HANG 1
+42 if 'NEW
QUIT
+43 SET DIR("A")="Enter a new agreement"
+44 SET DIR(0)="Y"
+45 DO ^DIR
+46 if +Y=1
SET OUT=0
End DoDot:1
QUIT OUT
+47 ;
+48 ; Next display all of the current IPAC Vendor Agreements
+49 SET DIR(0)="FO"
SET LN=0
+50 if NEW
SET DIR("B")="NEW"
+51 SET LN=LN+1
SET DIR("A",LN)=FLINE
+52 SET LN=LN+1
SET DIR("A",LN)=" "
+53 SET LN=LN+1
SET DIR("A",LN)="# ID FY Vendor S Description"
+54 SET LN=LN+1
SET DIR("A",LN)="-- ---------- ---- ------------------------------ - -------------------------"
+55 SET IX=""
+56 FOR
Begin DoDot:1
+57 SET IX=$ORDER(VADATA(IX))
+58 if IX=""
QUIT
+59 SET LN=LN+1
SET DIR("A",LN)=$PIECE(VADATA(IX),U,2)
End DoDot:1
if IX=""
QUIT
+60 ; Just display, no selection
IF STEXT=""
Begin DoDot:1
+61 WRITE !!
+62 SET LN=""
+63 FOR
Begin DoDot:2
+64 SET LN=$ORDER(DIR("A",LN))
+65 if LN=""
QUIT
+66 WRITE !,DIR("A",LN)
End DoDot:2
if LN=""
QUIT
End DoDot:1
QUIT ""
+67 SET LN=LN+1
SET DIR("A",LN)=" "
+68 SET LN=LN+1
SET DIR("A",LN)=STEXT
+69 SET DIR("A")="Selection #"
SELVA1 ; Looping tag
+1 WRITE !!
+2 KILL X,Y
+3 DO ^DIR
+4 ; User timed out or pressed ^
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT ""
+5 SET XX=$$UP^XLFSTR(Y)
+6 ; Creating a new one
IF NEW
if (XX="NEW")!(XX="N")!(XX="NE")!(XX="")
QUIT 0
+7 ; User quitting
IF 'NEW
if XX=""
QUIT ""
+8 ; Selected IEN
IF XX>0
IF XX'>CNT
IF XX?.N
QUIT $PIECE(VADATA(XX),U,1)
+9 ;
+10 WRITE !!,*7,"Enter a number from 1-"_CNT
+11 if NEW
WRITE " or Type 'NEW'"
+12 HANG 1
+13 GOTO SELVA1
+14 ;
SELMRA(FLINE,STEXT,STATUS,ACTION) ;EP
+1 ; Displays all of the currently filed MRA records with a status of 'T' and
+2 ; allows the user to select one
+3 ; Input: FLINE - Text of the first line to be displayed
+4 ; STEXT - User Selection prompt to be displayed
+5 ; STATUS - 'P' - Display pending MRA Records
+6 ; 'T' - Display transmitted MRA records
+7 ; '' - Display both pending and transmitted records
+8 ; ACTION - 'A' - Display Add MRA records
+9 ; 'C' - Display Change MRA records
+10 ; 'D' - Display Deleted MRA records
+11 ; '' - Display MRA records with any type of action
+12 ; Output: MRA Records that match the specified criteria are displayed to the screen.
+13 ; If there are none, a message is displayed
+14 ; Returns: MRAIEN - IEN of the selected MRA Record
+15 ; "" - No MRA record was selected
+16 NEW CNT,LN,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IX,MRAACT,MRADATA,MRAIEN,MRASTAT
+17 NEW OUT,TDT,VAIEN,VENIEN,X,XX,Y,ZZ
+18 ;
+19 ; First create and array of all current MRA records that match the selection criteria
+20 SET CNT=0
SET MRAIEN=0
+21 FOR
Begin DoDot:1
+22 SET MRAIEN=$ORDER(^FBAA(161.96,MRAIEN))
+23 if +MRAIEN=0
QUIT
+24 SET ZZ=^FBAA(161.96,MRAIEN,0)
+25 ; Action of the MRA Record
SET MRAACT=$PIECE(ZZ,U,4)
+26 ; Status of the MRA Record
SET MRASTAT=$PIECE(ZZ,U,5)
+27 ; Not the specified status
IF STATUS'=""
IF STATUS'=MRASTAT
QUIT
+28 ; Not the specified action
IF ACTION'=""
IF ACTION'=MRAACT
QUIT
+29 SET CNT=CNT+1
+30 ; Selection #
SET XX=$$LJ^XLFSTR(CNT,3)
+31 ; IPAC Agreement ID
SET XX=XX_$$LJ^XLFSTR($PIECE(ZZ,U,3),11)
+32 ; Status
SET XX=XX_$$LJ^XLFSTR(MRASTAT,2)
+33 ; Action
SET XX=XX_$$LJ^XLFSTR(MRAACT,2)
+34 ; Transmit Date
IF (STATUS="")!(STATUS="T")
Begin DoDot:2
+35 SET TDT=$PIECE(ZZ,U,6)
+36 ; Converted to external
if TDT'=""
SET TDT=$$FMTE^XLFDT(TDT,2)
+37 SET XX=XX_$$LJ^XLFSTR(TDT,9)
End DoDot:2
+38 ;
+39 ; Only displaying MRA records with an action of DELETE - no more columns to display
+40 IF ACTION="D"
SET MRADATA(CNT)=MRAIEN_U_XX
QUIT
+41 ; IPAC Agreement IEN
SET VAIEN=$PIECE(ZZ,U,2)
+42 ; Vendor IEN
SET VENIEN=$PIECE($GET(^FBAA(161.95,VAIEN,0)),U,2)
+43 ; Vendor Name
SET XX=XX_$$LJ^XLFSTR($$GET1^DIQ(161.2,VENIEN_",",.01),"30T")_" "
+44 ; Description
SET XX=XX_$$LJ^XLFSTR($PIECE(^FBAA(161.95,VAIEN,0),U,5),"23T")
+45 SET MRADATA(CNT)=MRAIEN_U_XX
End DoDot:1
if +MRAIEN=0
QUIT
+46 ;
+47 IF 'CNT
Begin DoDot:1
+48 SET OUT=""
+49 if STEXT=""
QUIT
+50 WRITE !!,"No MRA records that match the specified criteria are currently on file."
End DoDot:1
QUIT OUT
+51 ;
+52 ; Next display all of the found MRA Records
+53 SET DIR(0)="FO"
SET LN=0
+54 SET LN=LN+1
SET DIR("A",LN)=FLINE
+55 SET LN=LN+1
SET DIR("A",LN)=" "
+56 SET LN=LN+1
SET DIR("A",LN)="# ID A "
+57 IF (STATUS="")!(STATUS="T")
Begin DoDot:1
+58 SET DIR("A",LN)=DIR("A",LN)_"S Trans Dt "
End DoDot:1
+59 IF (ACTION'="D")
Begin DoDot:1
+60 SET DIR("A",LN)=DIR("A",LN)_"Vendor Description"
End DoDot:1
+61 SET LN=LN+1
SET DIR("A",LN)="-- ---------- - "
+62 IF (STATUS="")!(STATUS="T")
Begin DoDot:1
+63 SET DIR("A",LN)=DIR("A",LN)_"- -------- "
End DoDot:1
+64 IF (ACTION'="D")
Begin DoDot:1
+65 SET DIR("A",LN)=DIR("A",LN)_"------------------------------ ----------------------"
End DoDot:1
+66 SET IX=""
+67 FOR
Begin DoDot:1
+68 SET IX=$ORDER(MRADATA(IX))
+69 if IX=""
QUIT
+70 SET LN=LN+1
SET DIR("A",LN)=$PIECE(MRADATA(IX),U,2)
End DoDot:1
if IX=""
QUIT
+71 SET LN=LN+1
SET DIR("A",LN)=" "
+72 SET LN=LN+1
SET DIR("A",LN)=STEXT
+73 SET DIR("A")="Selection #"
SELMRA1 ; Looping tag
+1 WRITE !!
+2 KILL X,Y
+3 DO ^DIR
+4 ; User timed out or pressed ^
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT ""
+5 SET XX=$$UP^XLFSTR(Y)
+6 ; User quitting
if XX=""
QUIT ""
+7 ; Selected IEN
IF XX>0
IF XX'>CNT
IF XX?.N
QUIT $PIECE(MRADATA(XX),U,1)
+8 ;
+9 WRITE !!,*7,"Enter a number from 1-"_CNT
+10 HANG 1
+11 GOTO SELMRA1
+12 ;
VADISP(VAIEN,TOSCREEN,VAOUT) ;EP
+1 ; Returns the IPAC Vendor Agreement Display Layout for a specified vendor
+2 ; agreement
+3 ; Input: VAIEN - Vendor Agreement IEN to build display layout for
+4 ; TOSCREEN - 1 - Display the Vendor Agreement to the screen, don't return VAOUT
+5 ; 0 - Don't display it, return array VAOUT instead
+6 ; Output: VAOUT - Array of IPAC Vendor Agreement Display Layout lines
+7 ; Only returned if TOSCREEN=0
+8 ;
+9 NEW LN,VADATA,XX
+10 KILL VAOUT
+11 ; Invalid Vendor Agreement
+12 if '$DATA(^FBAA(161.95,VAIEN))
QUIT
+13 ;
+14 DO VALOAD(VAIEN,.VADATA)
+15 SET XX=VADATA("ID")
SET VAOUT(1)="IPAC Vendor Agreement ID: "_$$LJ^XLFSTR(XX,12)
+16 SET XX=VADATA("STAT")
SET VAOUT(1)=VAOUT(1)_"Status: "_$$LJ^XLFSTR(XX,10)
+17 SET XX=VADATA("FY")
SET VAOUT(1)=VAOUT(1)_"FY: "_$$LJ^XLFSTR(XX,1,6)
+18 SET XX=VADATA("VENDOR")
SET VAOUT(2)="Vendor: "_$$LJ^XLFSTR(XX,48)
+19 SET XX=VADATA("DESC")
SET VAOUT(3)=" Desc: "_$$LJ^XLFSTR(XX,62)
+20 SET XX=VADATA("SHAN")
SET VAOUT(4)=" Sharing Agreement #: "_$$LJ^XLFSTR(XX,"15T")
+21 SET XX=VADATA("CALC")
SET VAOUT(5)="Customer ALC: "_$$LJ^XLFSTR(XX,10)
+22 SET XX=VADATA("RTAS")
SET VAOUT(5)=VAOUT(5)_"Receiver TAS: "_$$LJ^XLFSTR(XX,"29T")
+23 SET XX=VADATA("STAS")
SET VAOUT(6)=$$LJ^XLFSTR("",24," ")_" Sender TAS: "_$$LJ^XLFSTR(XX,"29T")
+24 SET XX=VADATA("ASN")
SET VAOUT(7)="Agency Field Station #: "_$$LJ^XLFSTR(XX,"10T")
+25 SET XX=VADATA("OB")
SET VAOUT(7)=VAOUT(7)_"Obligating Document #: "_$$LJ^XLFSTR(XX,"19T")
+26 SET VAOUT(8)="Station Contact: "
+27 SET XX=VADATA("CON")
SET VAOUT(9)=" Name: "_$$LJ^XLFSTR(XX,62)
+28 SET XX=VADATA("CONPHN")
SET VAOUT(10)=" Phone: "_$$LJ^XLFSTR(XX,"17T")
+29 ; 1st 40 chars or email
SET XX=VADATA("CONEM")
SET VAOUT(10)=VAOUT(10)_" Email: "_$$LJ^XLFSTR(XX,"40T")
+30 ; Remaining chars of email
SET VAOUT(11)=$SELECT($LENGTH(XX)'>40:"",1:" "_$EXTRACT(XX,41,$LENGTH(XX)))
+31 SET VAOUT(12)="Complete Line of Accounting: "
+32 SET XX=VADATA("LOA")
SET VAOUT(13)=" "_$$LJ^XLFSTR(XX,62)
+33 SET VAOUT(14)="Description of Goods & Services: "
+34 SET XX=VADATA("GOOD")
SET VAOUT(15)=" "_$$LJ^XLFSTR(XX,"70T")
+35 ; Next 70 chars
SET VAOUT(16)=$SELECT($LENGTH(XX)'>70:"",1:" "_$EXTRACT(XX,71,140))
+36 ; Remaining chars
SET VAOUT(17)=$SELECT($LENGTH(XX)'>140:"",1:" "_$EXTRACT(XX,141,$LENGTH(XX)))
+37 SET VAOUT(18)="Miscellaneous Info: "
+38 SET XX=VADATA("MISC1")
SET VAOUT(19)="1) "_$$LJ^XLFSTR(XX,"75T")
+39 ; Next 75 chars
SET VAOUT(20)=$SELECT($LENGTH(XX)'>75:"",1:" "_$EXTRACT(XX,76,150))
+40 ; Remaining chars
SET VAOUT(21)=$SELECT($LENGTH(XX)'>150:"",1:" "_$EXTRACT(XX,151,$LENGTH(XX)))
+41 SET XX=VADATA("MISC2")
SET VAOUT(22)="2) "_$$LJ^XLFSTR(XX,"75T")
+42 ; Remaining chars
SET VAOUT(23)=$SELECT($LENGTH(XX)'>75:"",1:" "_$EXTRACT(XX,76,$LENGTH(XX)))
+43 if 'TOSCREEN
QUIT
+44 ;
+45 SET LN=""
+46 FOR
Begin DoDot:1
+47 SET LN=$ORDER(VAOUT(LN))
+48 if LN=""
QUIT
+49 IF VAOUT(LN)="***"
WRITE !
QUIT
+50 if $TRANSLATE(VAOUT(LN)," ","")'=""
WRITE !,VAOUT(LN)
End DoDot:1
if LN=""
QUIT
+51 KILL VAOUT
+52 QUIT
+53 ;
VALOAD(VAIEN,VADATA) ;EP
+1 ; Returns an array of external field values for a specified Vendor Agreement
+2 ; Input: VAIEN - Vendor Agreement IEN
+3 ; Output: VADATA("ASN") - Agency Field Station Number
+4 ; VADATA("CALC") - Customer ALC
+5 ; VADATA("CON") - Station Contact Name
+6 ; VADATA("CONEM") - Station Contact Email
+7 ; VADATA("CONPHN")- Station Contact Phone
+8 ; VADATA("DESC") - Vendor Agreement Description
+9 ; VADATA("FY") - Fiscal Year
+10 ; VADATA("GOOD") - Description of Goods and Services
+11 ; VADATA("ID") - Vendor Agreement ID
+12 ; VADATA("LOA") - Complete line of Accounting
+13 ; VADATA("OB") - Obligating document number
+14 ; VADATA("MISC1") - Miscellaneous Info 1
+15 ; VADATA("MISC2") - Miscellaneous Info 2
+16 ; VADATA("RTAS") - Receiver TAS
+17 ; VADATA("SHAN") - Sharing Agreement Number
+18 ; VADATA("STAS") - Sender TAS
+19 ; VADATA("STAT") - Vendor Agreement Status
+20 ; VADATA("VENDOR")- External Vendor name
+21 ;
+22 ;
+23 NEW IPAC
+24 DO GETS^DIQ(161.95,VAIEN_",","**","E","IPAC")
+25 SET VADATA("ID")=IPAC(161.95,VAIEN_",",".01","E")
+26 ;
+27 SET VADATA("VENDOR")=IPAC(161.95,VAIEN_",",1,"E")
+28 SET VADATA("FY")=IPAC(161.95,VAIEN_",",2,"E")
+29 SET VADATA("STAT")=IPAC(161.95,VAIEN_",",3,"E")
+30 SET VADATA("DESC")=IPAC(161.95,VAIEN_",",4,"E")
+31 SET VADATA("SHAN")=IPAC(161.95,VAIEN_",",5,"E")
+32 SET VADATA("CALC")=IPAC(161.95,VAIEN_",",6,"E")
+33 SET VADATA("RTAS")=IPAC(161.95,VAIEN_",",7,"E")
+34 SET VADATA("STAS")=IPAC(161.95,VAIEN_",",7.5,"E")
+35 SET VADATA("ASN")=IPAC(161.95,VAIEN_",",8,"E")
+36 SET VADATA("OB")=IPAC(161.95,VAIEN_",",9,"E")
+37 SET VADATA("CON")=IPAC(161.95,VAIEN_",",10,"E")
+38 SET VADATA("CONPHN")=IPAC(161.95,VAIEN_",",11,"E")
+39 SET VADATA("CONEM")=IPAC(161.95,VAIEN_",",12,"E")
+40 SET VADATA("LOA")=IPAC(161.95,VAIEN_",",13,"E")
+41 SET VADATA("GOOD")=IPAC(161.95,VAIEN_",",14,"E")
+42 SET VADATA("MISC1")=IPAC(161.95,VAIEN_",",15,"E")
+43 SET VADATA("MISC2")=IPAC(161.95,VAIEN_",",16,"E")
+44 QUIT
+45 ;
LOCKVA(VAIEN,DMSG) ;EP
+1 ; Attempt to lock IPAC Vendor Agreement
+2 ; Input: VAIEN - IPAC Vendor Agreement to be locked
+3 ; DMSG - 1 - Display locked message
+4 ; 0 - Don't display locked message
+5 ; Optional, defaults to 1
+6 ; Returns: 1 - IPAC Vendor Agreement locked, 0 otherwise
+7 ;
+8 if '$DATA(DMSG)
SET DMSG=1
+9 LOCK +^FBAA(161.95,VAIEN):0
+10 IF '$TEST
Begin DoDot:1
+11 if DMSG
WRITE !!,"Somebody is already editing this agreement. Try again later."
+12 HANG 1
End DoDot:1
QUIT 0
+13 QUIT 1
+14 ;
UNLOCKVA(VAIEN) ;EP
+1 ; Unlock the IPAC Vendor Agreement
+2 ; Input: VAIEN - Vendor Agreement to be locked
+3 ; Output: IPAC Vendor Agreement is unlocked
+4 LOCK -^FBAA(161.95,VAIEN)
+5 QUIT
+6 ;
