source: FOIAVistA/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPGET1.m

PPPGET1 ;ALB/DMB/DAD - PRESC. PRACT. GET ROUTINES ;10-AUG-93
 ;;1.0;PHARMACY PRESCRIPTION PRACTICE;**8,17,21,39**;APR 7,1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
GETDFN(PATIENT,VERBOSE) ;RETURN DFN OF PATIENT
 ;THIS WILL RETURN THE SAME INFORMATION THAT DIC RETURNS IN Y
 ;
 N DIC,X,Y,DTOUT,DUOUT,RESULT,USRABORT,DGSENFLG
 ;
 S DGSENFLG=""
 S USRABORT=-1001
 S:'$D(PATIENT) PATIENT=""
 S:'$D(VERBOSE) VERBOSE=0
 S VERBOSE=$S(VERBOSE:"E",1:"")
 ;
 ;USER INTERFACE
 S DIC(0)="M"_VERBOSE
 S:VERBOSE="" DIC(0)=DIC(0)_"X"
 I PATIENT="" D
 .S DIC(0)=DIC(0)_"AQ"
 S X=PATIENT
 S DIC=2
 D ^DIC
 ;
 ;USER ABORTED PROCESS
 ;
 I $D(DTOUT)!($D(DUOUT)) S RESULT=USRABORT
 E  S RESULT=Y
 ;
 Q RESULT
 ;
GETSNIFN(STATION,VERBOSE) ;RETURN IFN OF INSTITUTION
 ;THIS WILL RETURN THE SAME INFORMATION THAT DIC RETURNS IN Y
 ;
 N DIC,X,Y,DTOUT,DUOUT,RESULT,USRABORT
 ;
 S USRABORT=-1001
 S:'$D(STATION) STATION=""
 S:'$D(VERBOSE) VERBOSE=0
 S VERBOSE=$S(VERBOSE:"E",1:"")
 ;
 ;USER INTERFACE
 S DIC(0)="M"_VERBOSE
 I STATION="" D
 .S DIC(0)=DIC(0)_"AQ"
 E  D
 .S DIC(0)=DIC(0)_"X"
 S X=STATION
 S DIC=4
 D ^DIC
 ;
 ;USER ABORTED PROCESS
 ;
 I $D(DTOUT)!($D(DUOUT)) S RESULT=USRABORT
 E  S RESULT=Y
 ;
 Q RESULT
 ;
GETFFX(FFXIFN,TARRY) ; Get data from an FFX entry
 ;
 N DIC,DR,DA,DIQ,DUOUT,DTOUT,PARMERR,NODE0,NODE1,ARRAYTMP,TMPARRAY,FMERR
 ;
 S PARMERR=-9001
 S FMERR=-9002
 S TMPARRAY="ARRAYTMP"
 ;
 I '$D(FFXIFN) Q PARMERR
 I '$D(TARRY) Q PARMERR
 K @TMPARRAY
 ;
 ; Get the data from the entry
 ;
 S NODE0=$G(^PPP(1020.2,FFXIFN,0)) Q:$P(NODE0,"^")="" PARMERR
 S NODE1=$G(^PPP(1020.2,FFXIFN,1))
 ;
 ; Get the patient name and SSN from the patient file
 ;
 S DA=$P(NODE0,"^")
 I DA'="" D
 .S DR=".01;.09"
 .S DIC=2
 .S DIQ=TMPARRAY
 .S DIQ(0)="E"
 .D EN^DIQ1
 .I '$D(@TMPARRAY) Q FMERR
 .S @TARRY@(FFXIFN,"NAME")=$G(@TMPARRAY@(2,DA,.01,"E"))
 .S @TARRY@(FFXIFN,"SSN")=$G(@TMPARRAY@(2,DA,.09,"E"))
 .K @TMPARRAY
 E  D
 .S @TARRY@(FFXIFN,"NAME")="NOT AVAILABLE"
 .S @TARRY@(FFXIFN,"SSN")="NOT AVAILABLE"
 ;
 ; Get the institution info from file 4
 ;
 S DA=$P(NODE0,"^",2)
 I DA'="" D
 .;VMP OIFO BAY PINES;VGF;PPP*1.0*39
 .S DOMAIN=$$DOMAIN^PPPFMX(FFXIFN)
 .S LNUM=0 I DOMAIN]"" S LNUM=$O(^PPP(1020.128,"A",DOMAIN,0))
 .I LNUM S DOMAIN=$P(^PPP(1020.128,LNUM,0),"^",2)
 .S @TARRY@(FFXIFN,"STANO")=$$GETSTANO(DA)
 .S @TARRY@(FFXIFN,"POV")=$P(DOMAIN,".",1)
 .K @TMPARRAY
 E  D
 .S @TARRY@(FFXIFN,"POV")="NOT AVAILABLE"
 .S @TARRY@(FFXIFN,"STANO")="NOT AVAILABLE"
 ;
 ; Now fill in the rest of the data
 ;
 I $P(NODE0,"^",3)'="" D
 .S @TARRY@(FFXIFN,"LVD")=$$I2EDT^PPPCNV1($P(NODE0,"^",3))
 E  S @TARRY@(FFXIFN,"LVD")="NOT AVAILABLE"
 I $P(NODE1,"^",2)'="" D
 .S @TARRY@(FFXIFN,"LPDX")=$$I2EDT^PPPCNV1($P(NODE1,"^",2))
 E  S @TARRY@(FFXIFN,"LPDX")="NOT AVAILABLE"
 ;VMP OIFO BAY PINES;VGF;PPP*1.0*39
 I $G(DOMAIN)]"" D
 .S @TARRY@(FFXIFN,"DOMAIN")=$G(DOMAIN)
 E  S @TARRY@(FFXIFN,"DOMAIN")="NOT AVAILABLE"
 I $P(NODE1,"^",3)'="" D
 .S @TARRY@(FFXIFN,"STATUS")=$P($$GETPDXST^PPPGET7($P(NODE1,"^",3)),"^",2)
 E  S @TARRY@(FFXIFN,"STATUS")="NOT AVAILABLE"
 I $P(NODE1,"^",4)'="" D
 .S @TARRY@(FFXIFN,"LBRD")=$$I2EDT^PPPCNV1($P(NODE1,"^",4))
 E  S @TARRY@(FFXIFN,"LBRD")="NOT AVAILABLE"
 I $P(NODE0,"^",4)'="" D
 .S @TARRY@(FFXIFN,"SOURCE")=$S(($P(NODE0,"^",4)=1):"MANUAL",1:"AUTO")
 E  S @TARRY@(FFXIFN,"SOURCE")="NOT AVAILABLE"
 I $P(NODE0,"^",5)'="" D
 .S @TARRY@(FFXIFN,"ED")=$$I2EDT^PPPCNV1($P(NODE0,"^",5))
 E  S @TARRY@(FFXIFN,"ED")="NOT AVAILABLE"
 Q 0
 ;
GETFFIFN(PATDFN,SNIFN) ; Get the FFX ifn for a patient/station entry
 ;
 N PARMERR,FINDERR,FFIFN
 ;
 S PARMERR=-9001
 S FINDERR=-9003
 ;
 I '$D(PATDFN) K PPPSRT Q PARMERR
 I '$D(SNIFN) K PPPSRT Q PARMERR
 ;
 S FFIFN=$O(^PPP(1020.2,"APOV",PATDFN,SNIFN,""))
 I FFIFN'>0 Q FINDERR
 Q FFIFN
 ;
GETSSN(DFN) ;
 ;
 N DIC,DA,DR,DIQ,PPPTMP,SSN,DUOUT,DTOUT
 ;
 S DIC=2,DA=DFN,DR=".09",DIQ="PPPTMP",DIQ(0)="E"
 D EN^DIQ1
 S SSN=$G(PPPTMP(2,DFN,.09,"E"))
 I SSN="" Q -1
 Q SSN
 ;
GETSTANO(SNIFN) ;
 I $D(^DIC(4,"D",SNIFN)) S STANO=SNIFN Q STANO
 I $D(^PPP(1020.8,"B",SNIFN)) S STANO=SNIFN Q STANO
 ;
 N DIC,DA,DR,DIQ,PPPTMP,STANO
 ;
 S DIC=4,DA=SNIFN,DR="99",DIQ="PPPTMP",DIQ(0)="E"
 ;PPP*1*21
 D EN^DIQ1
 S STANO=$G(PPPTMP(4,SNIFN,99,"E"))
 I STANO="",$D(^PPP(1020.8,"B",SNIFN)) S STANO=SNIFN
 I STANO="" Q -1
 Q STANO
 ;
GETPATNM(DFN) ;
 ;
 N DIC,DA,DR,DIQ,PPPTMP,NAME
 ;
 S DIC=2,DA=DFN,DR=".01",DIQ="PPPTMP",DIQ(0)="E"
 D EN^DIQ1
 S NAME=$G(PPPTMP(2,DFN,.01,"E"))
 I NAME="" Q -1
 Q NAME
 ;
GETSTANM(SNIFN) ;
 ;
 N NAME
 ;VMP OIFO BAY PINES;VGF;PPP*1.0*39
 S SNIFN=$O(^PPP(1020.8,"B",SNIFN,""))
 I SNIFN="" Q -1
 S NAME=$P($G(^PPP(1020.8,SNIFN,0)),"^",2),NAME=$P(NAME,".",1)
 I NAME="" Q -1
 Q NAME