IBNCPUT2 ;BHAM ISC/SS - IB NCPDP UTILITIES ;23-JUL-2007
;;2.0;INTEGRATED BILLING;**363**;21-MAR-94;Build 35
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;Utilities for NPCDP
;
;Subroutine to return values from MULTIPLE fields of file #52
;DBIA 4858
;input:
; IBIEN52 - ien of file #52
; IBFLDN - one or more fields, for example ".01;2;5"
; IBRET - contains a name for a local array to return results,
; Note: the name of the array should't be "BPSRET" otherwise it will
; be "newed" since the parameter has the same name
; IBFORMAT -
; "E" for external format
; "I" - internal
; "N" - do not return nulls
; default is "E"
;output:
; result will be put into array with the name specified by BPSRET
RXAPI(IBIEN52,IBFLDN,IBRET,IBFORMAT) ;
I ($G(IBIEN52)="")!($G(IBFLDN)="")!($G(IBRET)="") Q
N DIQ,DIC,X,Y,D0,PSODIY
N I,J,C,DA,DRS,DIL,DI,DIQ1
N IBDIQ
S IBDIQ=$NA(@IBRET)
S IBDIQ(0)=$S($G(IBFORMAT)="":"E",1:IBFORMAT)
D DIQ^PSODI(52,52,.IBFLDN,.IBIEN52,.IBDIQ) ;DBIA 4858
Q
;Subroutine to return values from MULTIPLE fields of a subfile of the file #52
;DBIA 4858
;input:
; IBIEN52 - ien of file #52
; IBFLD52 - field # that relates to this subfile
; IBSUBFNO - subfile number (like 52.052311)
; IBSUBIEN - ien of the subfile record you're interested in
; IBSUBFLD - one or more fields, for example ".01;2;5"
; IBRET - name for a local array to return results
; IBFORMAT - optional parameter.
; "E" for external format
; "I" - internal
; "N" - do not return nulls
; default is "E"
;output:
; returns results in array BPSRET in the form:
; IBRET (IBSUBFNO, IBSUBIEN, IBSUBFLD,IBFORMAT)=value
RXSUBF(IBIEN52,IBFLD52,IBSUBFNO,IBSUBIEN,IBSUBFLD,IBRET,IBFORMAT) ;
I ($G(IBIEN52)="")!($G(IBFLD52)="")!($G(IBSUBFNO)="")!($G(IBSUBIEN)="")!($G(IBSUBFLD)="")!($G(IBRET)="") Q
N DIQ,DIC,DA,DR,X,Y,D0,PSODIY
N I,J,C,DA,DRS,DIL,DI,DIQ1
N IBDIC,IBDR,IBDA,IBDIQ
S IBDIC=52 ;main file #52
S IBDA=IBIEN52 ;ien in main file #52
S IBDA(IBSUBFNO)=IBSUBIEN ;ien in subfile
S IBDR=IBFLD52 ;field# of the subfile in the main file
S IBDR(IBSUBFNO)=IBSUBFLD ;field# in the subfile that we need to get a value for
S IBDIQ=$NA(@IBRET) ;output array
S IBDIQ(0)=$S($G(IBFORMAT)="":"E",1:IBFORMAT)
D DIQ^PSODI(52,.IBDIC,.IBDR,.IBDA,.IBDIQ) ;DBIA 4858
Q
;
;Retrieve indicators (AO,CV,etc) from the file #52
;input:
; IBRXIEN - ien of file #52
; .IBARRAY - local array passed by reference
;output:
; .IBARRAY
GETINDIC(IBRXIEN,IBARRAY) ;
;set all indicators nodes to null before populating
S IBARRAY("AO")="",IBARRAY("EC")="",IBARRAY("HNC")="",IBARRAY("IR")=""
S IBARRAY("MST")="",IBARRAY("SC")="",IBARRAY("CV")="",IBARRAY("SWA")="",IBARRAY("SHAD")=""
N IBARR,IBFOUND
; Get SC/EI from ICD subfile (new way)
D RXSUBF(IBRXIEN,52311,52.052311,1,"1;2;3;4;5;6;7;8","IBARR","I")
S IBFOUND=0
I $G(IBARR(52.052311,1,1,"I"))'="" S IBARRAY("AO")=IBARR(52.052311,1,1,"I"),IBFOUND=1
I $G(IBARR(52.052311,1,2,"I"))'="" S IBARRAY("IR")=IBARR(52.052311,1,2,"I"),IBFOUND=1
I $G(IBARR(52.052311,1,3,"I"))'="" S IBARRAY("SC")=IBARR(52.052311,1,3,"I"),IBFOUND=1
I $G(IBARR(52.052311,1,4,"I"))'="" S IBARRAY("SWA")=IBARR(52.052311,1,4,"I"),IBFOUND=1
I $G(IBARR(52.052311,1,5,"I"))'="" S IBARRAY("MST")=IBARR(52.052311,1,5,"I"),IBFOUND=1
I $G(IBARR(52.052311,1,6,"I"))'="" S IBARRAY("HNC")=IBARR(52.052311,1,6,"I"),IBFOUND=1
I $G(IBARR(52.052311,1,7,"I"))'="" S IBARRAY("CV")=IBARR(52.052311,1,7,"I"),IBFOUND=1
I $G(IBARR(52.052311,1,8,"I"))'="" S IBARRAY("SHAD")=IBARR(52.052311,1,8,"I"),IBFOUND=1
Q:IBFOUND=1
; If not available, pull from IBQ node (old way)
K IBARR
D RXAPI(IBRXIEN,"116;117;118;119;120;121;122;122.01","IBARR","I")
S IBARRAY("SC")=IBARR(52,IBRXIEN,116,"I")
S IBARRAY("MST")=IBARR(52,IBRXIEN,117,"I")
S IBARRAY("AO")=IBARR(52,IBRXIEN,118,"I")
S IBARRAY("IR")=IBARR(52,IBRXIEN,119,"I")
S IBARRAY("SWA")=IBARR(52,IBRXIEN,120,"I")
S IBARRAY("HNC")=IBARR(52,IBRXIEN,121,"I")
S IBARRAY("CV")=IBARR(52,IBRXIEN,122,"I")
S IBARRAY("SHAD")=$G(IBARR(52,IBRXIEN,122.01,"I"))
Q
;IBNCPUT2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPUT2 4169 printed Sep 23, 2025@20:01:26 Page 2
IBNCPUT2 ;BHAM ISC/SS - IB NCPDP UTILITIES ;23-JUL-2007
+1 ;;2.0;INTEGRATED BILLING;**363**;21-MAR-94;Build 35
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Utilities for NPCDP
+5 ;
+6 ;Subroutine to return values from MULTIPLE fields of file #52
+7 ;DBIA 4858
+8 ;input:
+9 ; IBIEN52 - ien of file #52
+10 ; IBFLDN - one or more fields, for example ".01;2;5"
+11 ; IBRET - contains a name for a local array to return results,
+12 ; Note: the name of the array should't be "BPSRET" otherwise it will
+13 ; be "newed" since the parameter has the same name
+14 ; IBFORMAT -
+15 ; "E" for external format
+16 ; "I" - internal
+17 ; "N" - do not return nulls
+18 ; default is "E"
+19 ;output:
+20 ; result will be put into array with the name specified by BPSRET
RXAPI(IBIEN52,IBFLDN,IBRET,IBFORMAT) ;
+1 IF ($GET(IBIEN52)="")!($GET(IBFLDN)="")!($GET(IBRET)="")
QUIT
+2 NEW DIQ,DIC,X,Y,D0,PSODIY
+3 NEW I,J,C,DA,DRS,DIL,DI,DIQ1
+4 NEW IBDIQ
+5 SET IBDIQ=$NAME(@IBRET)
+6 SET IBDIQ(0)=$SELECT($GET(IBFORMAT)="":"E",1:IBFORMAT)
+7 ;DBIA 4858
DO DIQ^PSODI(52,52,.IBFLDN,.IBIEN52,.IBDIQ)
+8 QUIT
+9 ;Subroutine to return values from MULTIPLE fields of a subfile of the file #52
+10 ;DBIA 4858
+11 ;input:
+12 ; IBIEN52 - ien of file #52
+13 ; IBFLD52 - field # that relates to this subfile
+14 ; IBSUBFNO - subfile number (like 52.052311)
+15 ; IBSUBIEN - ien of the subfile record you're interested in
+16 ; IBSUBFLD - one or more fields, for example ".01;2;5"
+17 ; IBRET - name for a local array to return results
+18 ; IBFORMAT - optional parameter.
+19 ; "E" for external format
+20 ; "I" - internal
+21 ; "N" - do not return nulls
+22 ; default is "E"
+23 ;output:
+24 ; returns results in array BPSRET in the form:
+25 ; IBRET (IBSUBFNO, IBSUBIEN, IBSUBFLD,IBFORMAT)=value
RXSUBF(IBIEN52,IBFLD52,IBSUBFNO,IBSUBIEN,IBSUBFLD,IBRET,IBFORMAT) ;
+1 IF ($GET(IBIEN52)="")!($GET(IBFLD52)="")!($GET(IBSUBFNO)="")!($GET(IBSUBIEN)="")!($GET(IBSUBFLD)="")!($GET(IBRET)="")
QUIT
+2 NEW DIQ,DIC,DA,DR,X,Y,D0,PSODIY
+3 NEW I,J,C,DA,DRS,DIL,DI,DIQ1
+4 NEW IBDIC,IBDR,IBDA,IBDIQ
+5 ;main file #52
SET IBDIC=52
+6 ;ien in main file #52
SET IBDA=IBIEN52
+7 ;ien in subfile
SET IBDA(IBSUBFNO)=IBSUBIEN
+8 ;field# of the subfile in the main file
SET IBDR=IBFLD52
+9 ;field# in the subfile that we need to get a value for
SET IBDR(IBSUBFNO)=IBSUBFLD
+10 ;output array
SET IBDIQ=$NAME(@IBRET)
+11 SET IBDIQ(0)=$SELECT($GET(IBFORMAT)="":"E",1:IBFORMAT)
+12 ;DBIA 4858
DO DIQ^PSODI(52,.IBDIC,.IBDR,.IBDA,.IBDIQ)
+13 QUIT
+14 ;
+15 ;Retrieve indicators (AO,CV,etc) from the file #52
+16 ;input:
+17 ; IBRXIEN - ien of file #52
+18 ; .IBARRAY - local array passed by reference
+19 ;output:
+20 ; .IBARRAY
GETINDIC(IBRXIEN,IBARRAY) ;
+1 ;set all indicators nodes to null before populating
+2 SET IBARRAY("AO")=""
SET IBARRAY("EC")=""
SET IBARRAY("HNC")=""
SET IBARRAY("IR")=""
+3 SET IBARRAY("MST")=""
SET IBARRAY("SC")=""
SET IBARRAY("CV")=""
SET IBARRAY("SWA")=""
SET IBARRAY("SHAD")=""
+4 NEW IBARR,IBFOUND
+5 ; Get SC/EI from ICD subfile (new way)
+6 DO RXSUBF(IBRXIEN,52311,52.052311,1,"1;2;3;4;5;6;7;8","IBARR","I")
+7 SET IBFOUND=0
+8 IF $GET(IBARR(52.052311,1,1,"I"))'=""
SET IBARRAY("AO")=IBARR(52.052311,1,1,"I")
SET IBFOUND=1
+9 IF $GET(IBARR(52.052311,1,2,"I"))'=""
SET IBARRAY("IR")=IBARR(52.052311,1,2,"I")
SET IBFOUND=1
+10 IF $GET(IBARR(52.052311,1,3,"I"))'=""
SET IBARRAY("SC")=IBARR(52.052311,1,3,"I")
SET IBFOUND=1
+11 IF $GET(IBARR(52.052311,1,4,"I"))'=""
SET IBARRAY("SWA")=IBARR(52.052311,1,4,"I")
SET IBFOUND=1
+12 IF $GET(IBARR(52.052311,1,5,"I"))'=""
SET IBARRAY("MST")=IBARR(52.052311,1,5,"I")
SET IBFOUND=1
+13 IF $GET(IBARR(52.052311,1,6,"I"))'=""
SET IBARRAY("HNC")=IBARR(52.052311,1,6,"I")
SET IBFOUND=1
+14 IF $GET(IBARR(52.052311,1,7,"I"))'=""
SET IBARRAY("CV")=IBARR(52.052311,1,7,"I")
SET IBFOUND=1
+15 IF $GET(IBARR(52.052311,1,8,"I"))'=""
SET IBARRAY("SHAD")=IBARR(52.052311,1,8,"I")
SET IBFOUND=1
+16 if IBFOUND=1
QUIT
+17 ; If not available, pull from IBQ node (old way)
+18 KILL IBARR
+19 DO RXAPI(IBRXIEN,"116;117;118;119;120;121;122;122.01","IBARR","I")
+20 SET IBARRAY("SC")=IBARR(52,IBRXIEN,116,"I")
+21 SET IBARRAY("MST")=IBARR(52,IBRXIEN,117,"I")
+22 SET IBARRAY("AO")=IBARR(52,IBRXIEN,118,"I")
+23 SET IBARRAY("IR")=IBARR(52,IBRXIEN,119,"I")
+24 SET IBARRAY("SWA")=IBARR(52,IBRXIEN,120,"I")
+25 SET IBARRAY("HNC")=IBARR(52,IBRXIEN,121,"I")
+26 SET IBARRAY("CV")=IBARR(52,IBRXIEN,122,"I")
+27 SET IBARRAY("SHAD")=$GET(IBARR(52,IBRXIEN,122.01,"I"))
+28 QUIT
+29 ;IBNCPUT2
