source: WorldVistAEHR/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPSCN1.m@ 1800

PPPSCN1 ;ALB/DMB - PPP XREF SCAN ROUTINE ; 2/18/91
 ;;V1.0;PHARMACY PRESCRIPTION PRACTICE;;APR 7,1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
XREFSCAN ; Scan the FFX file for bad PDX results
 ;
 N RSLTPTR,UNSPTR,PROCPTR,AUTOPTR,CODE,ERRORS,LBRD,TMP,XFIFN
 N XSCNEND,XSCNSTRT
 ;
 S PPPMRT="XREFSCAN_PPPSCN1"
 S XSCNSTRT=1004
 S XSCNEND=1005
 S ERRORS=0
 ;
 ; Get the IFN's for the PDX Status codes
 ;
 S RSLTPTR=$$GETSTPTR^PPPGET7("VAQ-RSLT")
 S UNSPTR=$$GETSTPTR^PPPGET7("VAQ-UNSOL")
 S PROCPTR=$$GETSTPTR^PPPGET7("VAQ-PROC")
 S AUTOPTR=$$GETSTPTR^PPPGET7("VAQ-AUTO")
 ;
 S TMP=$$LOGEVNT^PPPMSC1(XSCNSTRT,PPPMRT)
 S LBRD=$P(^PPP(1020.1,1,0),"^",6)
 I LBRD'="" D
 .S ^TMP("PPP",$J,"ERR",1)="The following status were found while running XREFSCAN for last PDX batch"
 .S ^TMP("PPP",$J,"ERR",2)="dated: "_$$DTE^PPPUTL1(LBRD,0)
 .S ^TMP("PPP",$J,"ERR",3)=" "
 .F XFIFN=0:0 D  Q:XFIFN=""
 ..S XFIFN=$O(^PPP(1020.2,"C",LBRD,XFIFN)) Q:XFIFN=""
 ..S CODE=$P($G(^PPP(1020.2,XFIFN,1)),"^",3)
 ..I ((CODE'=RSLTPTR)&(CODE'=UNSPTR)&(CODE'=PROCPTR)&(CODE'=AUTOPTR)) D
 ...S TMP=$$ADD2LIST("^TMP(""PPP"",$J,""ERR"")",XFIFN)
 ...S ERRORS=1
 E  D
 .S ^TMP("PPP",$J,"ERR",1)=" "
 .S ^TMP("PPP",$J,"ERR",2)="Last Batch Request Date Not Found"
 .S ERRORS=1
 I ERRORS D
 .S TMP=$$SNDBLTN^PPPMSC1("PPP - Nightly PDX Result Scan","PRESCRIPTION PRACTICES","^TMP(""PPP"",$J,""ERR"",")
 S TMP=$$LOGEVNT^PPPMSC1(XSCNEND,PPPMRT)
 K PPPMRT,^TMP("PPP",$J,"ERR")
 Q
 ;
ADD2LIST(ARRYNM,XRFIFN) ; Add an error to the error list
 ;
 N IDX,LKUPERR,PARMERR,PATDFN,PATNAME,SNIFN,STANAME,STATCODE,STATIFN
 N STATTXT,TMP,FFXDOM
 ;
 S PARMERR=-9001
 S LKUPERR=-9003
 ;
 ; Check Parameters
 ;
 I '$D(ARRYNM) Q PARMERR
 I '$D(XRFIFN) Q PARMERR
 I ARRYNM=""!(XRFIFN<1) Q PARMERR
 ;
 ; Get the patient name
 ;
 S PATDFN=$P($G(^PPP(1020.2,XRFIFN,0)),"^")
 I PATDFN="" Q LKUPERR
 S PATNAME=$$GETPATNM^PPPGET1(PATDFN) Q:PATNAME<0 LKUPERR
 ;
 ; Get the station name/domain
 ;
 S FFXDOM=$P($G(^PPP(1020.2,XRFIFN,1)),"^",5)
 S SNIFN=$P($G(^PPP(1020.2,XRFIFN,0)),"^",2)
 I SNIFN="" Q LKUPERR
 S STANAME=$$GETSTANM^PPPGET1(SNIFN) Q:STANAME<0 LKUPERR
 ;
 ; Get the PDX Status and text from FFX file
 ;
 S STATCODE=""
 S STATTXT=""
 ;
 S STATIFN=$P($G(^PPP(1020.2,XRFIFN,1)),"^",3)
 I STATIFN'="" D
 .S TMP=$$GETPDXST^PPPGET7(STATIFN)
 .S STATCODE=$P(TMP,"^",1)
 .S STATTXT=$P(TMP,"^",2)
 ;
 I ((STATCODE="-1")!(STATCODE="")) D CHKPDX
 I ((STATCODE="-1")!(STATCODE="")) D
 .S STATCODE="NULL",STATTXT="NOTHING RETURNED"
 ;
 ; Set the array
 ;
 F IDX=1:1 D  Q:TMP=""
 .S TMP=$O(@ARRYNM@(IDX)) Q:TMP=""
 S @ARRYNM@(IDX+1)="PDX Status For "_PATNAME_" at "_STANAME_" is: "_STATTXT
 ;
 Q 0
 ;
CHKPDX ; -- Checks actual PDX when status is not in 1020.2
 N EXIT,PDXPTR
 ;
 S (PDXPTR,EXIT)=0
 F  S PDXPTR=$O(^VAT(394.61,"PATPTR",PATDFN,PDXPTR)) Q:PDXPTR=""!EXIT  D
 .S PDXDOM=$P($G(^VAT(394.61,PDXPTR,"ATHR2")),"^",2)
 .I PDXDOM=FFXDOM D
 ..S STATIFN=$P($G(^VAT(394.61,PDXPTR,0)),"^",2)
 ..S TMP=$$GETPDXST^PPPGET7(STATIFN)
 ..S STATCODE=$P(TMP,"^",1)
 ..S STATTXT=$P(TMP,"^",2)
 ..S EXIT=1
 ;
END ; -- End of code
 Q
 ;