- 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 ;
