Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBNCPUT2

IBNCPUT2.m

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