source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBNCPUT2.m@ 1261

Last change on this file since 1261 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.0 KB
RevLine 
[613]1IBNCPUT2 ;BHAM ISC/SS - IB NCPDP UTILITIES ;23-JUL-2007
2 ;;2.0;INTEGRATED BILLING;**363**;21-MAR-94;Build 35
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;Utilities for NPCDP
6 ;
7 ;Subroutine to return values from MULTIPLE fields of file #52
8 ;DBIA 4858
9 ;input:
10 ; IBIEN52 - ien of file #52
11 ; IBFLDN - one or more fields, for example ".01;2;5"
12 ; IBRET - contains a name for a local array to return results,
13 ; Note: the name of the array should't be "BPSRET" otherwise it will
14 ; be "newed" since the parameter has the same name
15 ; IBFORMAT -
16 ; "E" for external format
17 ; "I" - internal
18 ; "N" - do not return nulls
19 ; default is "E"
20 ;output:
21 ; result will be put into array with the name specified by BPSRET
22RXAPI(IBIEN52,IBFLDN,IBRET,IBFORMAT) ;
23 I ($G(IBIEN52)="")!($G(IBFLDN)="")!($G(IBRET)="") Q
24 N DIQ,DIC,X,Y,D0,PSODIY
25 N I,J,C,DA,DRS,DIL,DI,DIQ1
26 N IBDIQ
27 S IBDIQ=$NA(@IBRET)
28 S IBDIQ(0)=$S($G(IBFORMAT)="":"E",1:IBFORMAT)
29 D DIQ^PSODI(52,52,.IBFLDN,.IBIEN52,.IBDIQ) ;DBIA 4858
30 Q
31 ;Subroutine to return values from MULTIPLE fields of a subfile of the file #52
32 ;DBIA 4858
33 ;input:
34 ; IBIEN52 - ien of file #52
35 ; IBFLD52 - field # that relates to this subfile
36 ; IBSUBFNO - subfile number (like 52.052311)
37 ; IBSUBIEN - ien of the subfile record you're interested in
38 ; IBSUBFLD - one or more fields, for example ".01;2;5"
39 ; IBRET - name for a local array to return results
40 ; IBFORMAT - optional parameter.
41 ; "E" for external format
42 ; "I" - internal
43 ; "N" - do not return nulls
44 ; default is "E"
45 ;output:
46 ; returns results in array BPSRET in the form:
47 ; IBRET (IBSUBFNO, IBSUBIEN, IBSUBFLD,IBFORMAT)=value
48RXSUBF(IBIEN52,IBFLD52,IBSUBFNO,IBSUBIEN,IBSUBFLD,IBRET,IBFORMAT) ;
49 I ($G(IBIEN52)="")!($G(IBFLD52)="")!($G(IBSUBFNO)="")!($G(IBSUBIEN)="")!($G(IBSUBFLD)="")!($G(IBRET)="") Q
50 N DIQ,DIC,DA,DR,X,Y,D0,PSODIY
51 N I,J,C,DA,DRS,DIL,DI,DIQ1
52 N IBDIC,IBDR,IBDA,IBDIQ
53 S IBDIC=52 ;main file #52
54 S IBDA=IBIEN52 ;ien in main file #52
55 S IBDA(IBSUBFNO)=IBSUBIEN ;ien in subfile
56 S IBDR=IBFLD52 ;field# of the subfile in the main file
57 S IBDR(IBSUBFNO)=IBSUBFLD ;field# in the subfile that we need to get a value for
58 S IBDIQ=$NA(@IBRET) ;output array
59 S IBDIQ(0)=$S($G(IBFORMAT)="":"E",1:IBFORMAT)
60 D DIQ^PSODI(52,.IBDIC,.IBDR,.IBDA,.IBDIQ) ;DBIA 4858
61 Q
62 ;
63 ;Retrieve indicators (AO,CV,etc) from the file #52
64 ;input:
65 ; IBRXIEN - ien of file #52
66 ; .IBARRAY - local array passed by reference
67 ;output:
68 ; .IBARRAY
69GETINDIC(IBRXIEN,IBARRAY) ;
70 ;set all indicators nodes to null before populating
71 S IBARRAY("AO")="",IBARRAY("EC")="",IBARRAY("HNC")="",IBARRAY("IR")=""
72 S IBARRAY("MST")="",IBARRAY("SC")="",IBARRAY("CV")="",IBARRAY("SWA")="",IBARRAY("SHAD")=""
73 N IBARR,IBFOUND
74 ; Get SC/EI from ICD subfile (new way)
75 D RXSUBF(IBRXIEN,52311,52.052311,1,"1;2;3;4;5;6;7;8","IBARR","I")
76 S IBFOUND=0
77 I $G(IBARR(52.052311,1,1,"I"))'="" S IBARRAY("AO")=IBARR(52.052311,1,1,"I"),IBFOUND=1
78 I $G(IBARR(52.052311,1,2,"I"))'="" S IBARRAY("IR")=IBARR(52.052311,1,2,"I"),IBFOUND=1
79 I $G(IBARR(52.052311,1,3,"I"))'="" S IBARRAY("SC")=IBARR(52.052311,1,3,"I"),IBFOUND=1
80 I $G(IBARR(52.052311,1,4,"I"))'="" S IBARRAY("SWA")=IBARR(52.052311,1,4,"I"),IBFOUND=1
81 I $G(IBARR(52.052311,1,5,"I"))'="" S IBARRAY("MST")=IBARR(52.052311,1,5,"I"),IBFOUND=1
82 I $G(IBARR(52.052311,1,6,"I"))'="" S IBARRAY("HNC")=IBARR(52.052311,1,6,"I"),IBFOUND=1
83 I $G(IBARR(52.052311,1,7,"I"))'="" S IBARRAY("CV")=IBARR(52.052311,1,7,"I"),IBFOUND=1
84 I $G(IBARR(52.052311,1,8,"I"))'="" S IBARRAY("SHAD")=IBARR(52.052311,1,8,"I"),IBFOUND=1
85 Q:IBFOUND=1
86 ; If not available, pull from IBQ node (old way)
87 K IBARR
88 D RXAPI(IBRXIEN,"116;117;118;119;120;121;122;122.01","IBARR","I")
89 S IBARRAY("SC")=IBARR(52,IBRXIEN,116,"I")
90 S IBARRAY("MST")=IBARR(52,IBRXIEN,117,"I")
91 S IBARRAY("AO")=IBARR(52,IBRXIEN,118,"I")
92 S IBARRAY("IR")=IBARR(52,IBRXIEN,119,"I")
93 S IBARRAY("SWA")=IBARR(52,IBRXIEN,120,"I")
94 S IBARRAY("HNC")=IBARR(52,IBRXIEN,121,"I")
95 S IBARRAY("CV")=IBARR(52,IBRXIEN,122,"I")
96 S IBARRAY("SHAD")=$G(IBARR(52,IBRXIEN,122.01,"I"))
97 Q
98 ;IBNCPUT2
Note: See TracBrowser for help on using the repository browser.