PSBOPM1 ;BIRMINGHAM/BSR-BCMA OIT HISTORY API ;Oct 2005
;;3.0;BAR CODE MED ADMIN;**17**;Mar 2004;Build 1
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference/IA
; FILE 53.79
; X-REF AOIP
; X-REF AOIP3
; X-REF AOIP4
;
;
GETORD(PSBORDNM) ;
N XA,NDE
S PSBORD=0,XA=PSBORDNM,PSBDT="",NDE=.1
Q:PSBORDNM="" PSBORD
Q:'$D(^PSB(53.79,"AOIP",DFN,XA)) PSBORD
F S PSBDT=$O(^PSB(53.79,"AOIP",DFN,XA,PSBDT)) Q:PSBDT="" D
.S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP",DFN,XA,PSBDT,PSBIEN)) Q:PSBIEN="" D
..Q:$P($G(^PSB(53.79,PSBIEN,0)),U,9)="N"
..Q:'$D(^PSB(53.79,PSBIEN,NDE))
..S PSBORD=$P(^PSB(53.79,PSBIEN,NDE),U)
..I PSBORD S PSBORDNM=PSBORD
..S:'PSBORD!(PSBORD="") PSBORD=0,TMP("PSBOIS",$J,XA)=""
Q PSBORD
;
FINDIENS ; USE PSBOIS,PSBADDS AND PSBSOLS TO FIND ALL IENS FOR THE RPT
;SEARCH FOR UNIT DOSE IENS
I $D(TMP("PSBOIS",$J)) S XA="" F S XA=$O(TMP("PSBOIS",$J,XA)) Q:XA="" D
.S PSBDT="" F S PSBDT=$O(^PSB(53.79,"AOIP",DFN,XA,PSBDT)) Q:PSBDT="" D
..Q:PSBDT>PSBSTOP
..Q:PSBDT<PSBSTRT
..S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP",DFN,XA,PSBDT,PSBIEN)) Q:PSBIEN="" D
...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
...S TMP("PSBIENS",$J,"UD",$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
;
;SEARCH FOR ADDITIVES
I $D(TMP("PSBADDS",$J)) S XA="" F S XA=$O(TMP("PSBADDS",$J,XA)) Q:XA="" D
.S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP3",DFN,PSBIEN)) Q:PSBIEN="" D
..S XB="" F S XB=$O(^PSB(53.79,"AOIP3",DFN,PSBIEN,XB)) Q:XB="" D
...Q:XB'=XA
...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
...I $P(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT,$P(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP D
....S TMP("PSBIENS",$J,"ADD",$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
....S TMP("PSBADDS",$J,XA)=1
;
;SEARCH FOR SOLUTIONS
I $D(TMP("PSBSOLS",$J)) S XA="" F S XA=$O(TMP("PSBSOLS",$J,XA)) Q:XA="" D
.S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP4",DFN,PSBIEN)) Q:PSBIEN="" D
..S XB="" F S XB=$O(^PSB(53.79,"AOIP4",DFN,PSBIEN,XB)) Q:XB="" D
...Q:XB'=XA
...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
...I $P(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT,$P(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP D
....S TMP("PSBIENS",$J,"SOL",$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
....S TMP("PSBSOLS",$J,XA)=1
Q
;
PSBOPM1 ;BIRMINGHAM/BSR-BCMA OIT HISTORY API ;Oct 2005
+1 ;;3.0;BAR CODE MED ADMIN;**17**;Mar 2004;Build 1
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; FILE 53.79
+6 ; X-REF AOIP
+7 ; X-REF AOIP3
+8 ; X-REF AOIP4
+9 ;
+10 ;
GETORD(PSBORDNM) ;
+1 NEW XA,NDE
+2 SET PSBORD=0
SET XA=PSBORDNM
SET PSBDT=""
SET NDE=.1
+3 IF PSBORDNM=""
QUIT PSBORD
+4 IF '$DATA(^PSB(53.79,"AOIP",DFN,XA))
QUIT PSBORD
+5 FOR
SET PSBDT=$ORDER(^PSB(53.79,"AOIP",DFN,XA,PSBDT))
IF PSBDT=""
QUIT
Begin DoDot:1
+6 SET PSBIEN=""
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AOIP",DFN,XA,PSBDT,PSBIEN))
IF PSBIEN=""
QUIT
Begin DoDot:2
+7 IF $PIECE($GET(^PSB(53.79,PSBIEN,0)),U,9)="N"
QUIT
+8 IF '$DATA(^PSB(53.79,PSBIEN,NDE))
QUIT
+9 SET PSBORD=$PIECE(^PSB(53.79,PSBIEN,NDE),U)
+10 IF PSBORD
SET PSBORDNM=PSBORD
+11 IF 'PSBORD!(PSBORD="")
SET PSBORD=0
SET TMP("PSBOIS",$JOB,XA)=""
End DoDot:2
End DoDot:1
+12 QUIT PSBORD
+13 ;
FINDIENS ; USE PSBOIS,PSBADDS AND PSBSOLS TO FIND ALL IENS FOR THE RPT
+1 ;SEARCH FOR UNIT DOSE IENS
+2 IF $DATA(TMP("PSBOIS",$JOB))
SET XA=""
FOR
SET XA=$ORDER(TMP("PSBOIS",$JOB,XA))
IF XA=""
QUIT
Begin DoDot:1
+3 SET PSBDT=""
FOR
SET PSBDT=$ORDER(^PSB(53.79,"AOIP",DFN,XA,PSBDT))
IF PSBDT=""
QUIT
Begin DoDot:2
+4 IF PSBDT>PSBSTOP
QUIT
+5 IF PSBDT<PSBSTRT
QUIT
+6 SET PSBIEN=""
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AOIP",DFN,XA,PSBDT,PSBIEN))
IF PSBIEN=""
QUIT
Begin DoDot:3
+7 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="N"
QUIT
+8 SET TMP("PSBIENS",$JOB,"UD",$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+9 ;
+10 ;SEARCH FOR ADDITIVES
+11 IF $DATA(TMP("PSBADDS",$JOB))
SET XA=""
FOR
SET XA=$ORDER(TMP("PSBADDS",$JOB,XA))
IF XA=""
QUIT
Begin DoDot:1
+12 SET PSBIEN=""
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AOIP3",DFN,PSBIEN))
IF PSBIEN=""
QUIT
Begin DoDot:2
+13 SET XB=""
FOR
SET XB=$ORDER(^PSB(53.79,"AOIP3",DFN,PSBIEN,XB))
IF XB=""
QUIT
Begin DoDot:3
+14 IF XB'=XA
QUIT
+15 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="N"
QUIT
+16 IF $PIECE(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT
IF $PIECE(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP
Begin DoDot:4
+17 SET TMP("PSBIENS",$JOB,"ADD",$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
+18 SET TMP("PSBADDS",$JOB,XA)=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 ;SEARCH FOR SOLUTIONS
+21 IF $DATA(TMP("PSBSOLS",$JOB))
SET XA=""
FOR
SET XA=$ORDER(TMP("PSBSOLS",$JOB,XA))
IF XA=""
QUIT
Begin DoDot:1
+22 SET PSBIEN=""
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AOIP4",DFN,PSBIEN))
IF PSBIEN=""
QUIT
Begin DoDot:2
+23 SET XB=""
FOR
SET XB=$ORDER(^PSB(53.79,"AOIP4",DFN,PSBIEN,XB))
IF XB=""
QUIT
Begin DoDot:3
+24 IF XB'=XA
QUIT
+25 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="N"
QUIT
+26 IF $PIECE(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT
IF $PIECE(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP
Begin DoDot:4
+27 SET TMP("PSBIENS",$JOB,"SOL",$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
+28 SET TMP("PSBSOLS",$JOB,XA)=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
