source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOPM1.m@ 1604

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

initial load of WorldVistAEHR

File size: 2.2 KB
Line 
1PSBOPM1 ;BIRMINGHAM/BSR-BCMA OIT HISTORY API ;Oct 2005
2 ;;3.0;BAR CODE MED ADMIN;**17**;Mar 2004;Build 1
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; FILE 53.79
7 ; X-REF AOIP
8 ; X-REF AOIP3
9 ; X-REF AOIP4
10 ;
11 ;
12GETORD(PSBORDNM) ;
13 N XA,NDE
14 S PSBORD=0,XA=PSBORDNM,PSBDT="",NDE=.1
15 Q:PSBORDNM="" PSBORD
16 Q:'$D(^PSB(53.79,"AOIP",DFN,XA)) PSBORD
17 F S PSBDT=$O(^PSB(53.79,"AOIP",DFN,XA,PSBDT)) Q:PSBDT="" D
18 .S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP",DFN,XA,PSBDT,PSBIEN)) Q:PSBIEN="" D
19 ..Q:$P($G(^PSB(53.79,PSBIEN,0)),U,9)="N"
20 ..Q:'$D(^PSB(53.79,PSBIEN,NDE))
21 ..S PSBORD=$P(^PSB(53.79,PSBIEN,NDE),U)
22 ..I PSBORD S PSBORDNM=PSBORD
23 ..S:'PSBORD!(PSBORD="") PSBORD=0,TMP("PSBOIS",$J,XA)=""
24 Q PSBORD
25 ;
26FINDIENS ; USE PSBOIS,PSBADDS AND PSBSOLS TO FIND ALL IENS FOR THE RPT
27 ;SEARCH FOR UNIT DOSE IENS
28 I $D(TMP("PSBOIS",$J)) S XA="" F S XA=$O(TMP("PSBOIS",$J,XA)) Q:XA="" D
29 .S PSBDT="" F S PSBDT=$O(^PSB(53.79,"AOIP",DFN,XA,PSBDT)) Q:PSBDT="" D
30 ..Q:PSBDT>PSBSTOP
31 ..Q:PSBDT<PSBSTRT
32 ..S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP",DFN,XA,PSBDT,PSBIEN)) Q:PSBIEN="" D
33 ...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
34 ...S TMP("PSBIENS",$J,"UD",$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
35 ;
36 ;SEARCH FOR ADDITIVES
37 I $D(TMP("PSBADDS",$J)) S XA="" F S XA=$O(TMP("PSBADDS",$J,XA)) Q:XA="" D
38 .S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP3",DFN,PSBIEN)) Q:PSBIEN="" D
39 ..S XB="" F S XB=$O(^PSB(53.79,"AOIP3",DFN,PSBIEN,XB)) Q:XB="" D
40 ...Q:XB'=XA
41 ...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
42 ...I $P(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT,$P(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP D
43 ....S TMP("PSBIENS",$J,"ADD",$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
44 ....S TMP("PSBADDS",$J,XA)=1
45 ;
46 ;SEARCH FOR SOLUTIONS
47 I $D(TMP("PSBSOLS",$J)) S XA="" F S XA=$O(TMP("PSBSOLS",$J,XA)) Q:XA="" D
48 .S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP4",DFN,PSBIEN)) Q:PSBIEN="" D
49 ..S XB="" F S XB=$O(^PSB(53.79,"AOIP4",DFN,PSBIEN,XB)) Q:XB="" D
50 ...Q:XB'=XA
51 ...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
52 ...I $P(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT,$P(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP D
53 ....S TMP("PSBIENS",$J,"SOL",$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
54 ....S TMP("PSBSOLS",$J,XA)=1
55 Q
56 ;
Note: See TracBrowser for help on using the repository browser.