source: FOIAVistA/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPBFFX1.m@ 1783

PPPBFFX1 ;BHM/DB-Build off of CD_ROM continued ;3JUL97
 ;;1.0;PHARMACY PRESCRIPTION PRACTICE;**11,16,17,21,26**;APR 7, 1995
 K CNTR1,MAILERR,CNTR2,^TMP("PPP SORT",$J),PPPEND
PPPSTRT ;Starting point for extraction process
 ;@references to variable names generally represent extended globals
 ;@EXCARR@  = ["DEV","VAA"]^TMP("PPP",$J,"EXCLUDE")
 ;@MPDARR@  = ["DEV","VAA"]^TMP("PPP",$J,"RESULTS")
 ;@SORTSSN@ = ["DEV","VAA"]^DPT("SSN")
 ;@SSNARR@  = ["DEV","VAA"]^TMP("PPP",$J,"SSN")
 S PPP1=$G(^PPP(1020.1,1,1)),PPP0=$G(^PPP(1020.1,1,0))
 D NOW^%DTC S TODAY=$P(%,".") D YX^%DTC S STRTTM=Y
 K ERRTXT,DMNNEW,SSNCNT,Y,PATCHK,PATCHG,PATADD,SITECNT
 K ^TMP($J) D TXT S ^TMP($J,"PPPERR",ERRTXT)=" BUILD FOREIGN FACILITY CROSS REFERENCE FILE"
 S INUCI=$P(PPP1,"^"),OUTUCI=$P(PPP1,"^",2),PPPSTANO=$P(PPP0,"^",9)
 S XX="["""_$E(INUCI,1,3)_""","""_$E(INUCI,5,7)_"""]"
 S SORTSSN="^"_XX_"DPT("_"""SSN"""_")"
 S SSNARR="^"_XX_"TMP(""PPP"","_$J_",""SSN"")"
 S XX="["""_$E(OUTUCI,1,3)_""","""_$E(OUTUCI,5,7)_"""]"
 S MPDARR="^"_XX_"TMP(""PPP"","_$J_",""RESULTS"")"
 S EXCARR="^"_XX_"TMP(""PPP"","_$J_",""EXCLUDE"")"
 S KLLARRAY="^"_XX_"TMP(""PPP"")" S X=0 F  S X=$O(@KLLARRAY@(X)) Q:X=""  K @KLLARRAY@(X)
 S X=0 F  S X=$O(@MPDARR@(X)) Q:X=""  K @MPDARR@(X)
 S @EXCARR@(PPPSTANO)=""
 ;
1 ;
 S MAXTM=1000,STARTTM=$$NOW^PPPCNV1 ;Max time = 10 minutes
 F  S PPPSSN=$O(@SORTSSN@(PPPSSN)) Q:PPPSSN=""  S CNTR1=$G(CNTR1)+1,^TMP("PPP SORT",CNTR1)=PPPSSN,PPPEND=PPPSSN
 K CNTR,CNTR2,SSNCNT,PATCHK,PATCHG,PATADD,SITECNT,DMNNEW
2 S CNTR=$G(CNTR)+1,CNTR2=$G(CNTR2)+1,PPPSSN=$G(^TMP("PPP SORT",CNTR)) G 3:$G(PPPSSN)="" S @SSNARR@(PPPSSN)="",PPPEND=PPPSSN I $G(CNTR2)=100 G 3
 G 2
3 S X=0 F  S X=$O(@MPDARR@(X)) Q:X=""  K @MPDARR@(X)
 S STARTTM=$$NOW^PPPCNV1 G:$G(CNTR2)=1 FINI S X="VAMPAPI0" X ^%ZOSF("TEST") I $T S ERR=$$MPD^VAMPAPI0(SSNARR,MPDARR,"MPD**00001",EXCARR,600,1)
 I +ERR<0 S ERRTXT=$G(ERRTXT)+1,^TMP($J,"PPPERR",ERRTXT)="Error : "_$P(ERR,"^",2) G FINI
4 I $D(@MPDARR@("DONE",PPPEND)) K PPPSSN G BGN
 I $$DIFFTM^PPPCNV1($$NOW^PPPCNV1,STARTTM)>MAXTM S ERRTEXT=$G(ERRTXT)+1,^TMP($J,"PPPERR",ERRTXT)="      Timed out waiting for server to transfer data" S MAILERR=1 G FINI
 H .5 G 4
BGN ;begin compilation of data
 S PPPSSN=$S('$D(PPPSSN):$O(@MPDARR@("DONE",0)),1:$O(@MPDARR@("DONE",PPPSSN))) G NXTBTCH:PPPSSN="" S SSNCNT=$G(SSNCNT)+1
 S $P(^PPP(1020.1,1,2),"^",1)=PPPSSN
 I '$D(@MPDARR@(PPPSSN,"FOUND")) G BGN
 I @MPDARR@(PPPSSN,"FOUND")'>0 G BGN
 S PATDFN=$O(@SORTSSN@(PPPSSN,0)) I $G(PATDFN)'>0 G BGN
 S PPPSITE=0
FAC ;Get facilities visited
 S PPPSITE=$O(@MPDARR@(PPPSSN,"SITES",PPPSITE)) G BGN:PPPSITE'>0 K PPPERR1 D
 .;Get internal ien for station & domain name
 .I $D(^PPP(1020.5,"B",PPPSITE)) S PPPERR1=1 Q
 .I $D(^PPP(1020.8,"B",PPPSITE)) S PPPIEN=$O(^PPP(1020.8,"B",PPPSITE,0)),DMNNAME=$P($G(^PPP(1020.8,PPPIEN,0)),"^",2) Q
 .I $D(^PPP(1020.8,"D",PPPSITE)) S PPPIEN=$O(^PPP(1020.8,"D",PPPSITE,0)),DMNNAME=$P($G(^PPP(1020.8,PPPIEN,0)),"^",2) Q
 .I $D(^PPP(1020.8,PPPSITE)) S PPPIEN=PPPSITE Q
 .S DIC="^DIC(4,",DIC(0)="QMZ",X=PPPSITE,D="D" D IX^DIC I $D(Y),Y>0 S PPPIEN=+Y I $D(^PPP(1020.8,PPPIEN)) S DMNNAME=$P($G(^PPP(1020.8,PPPIEN,0)),"^",2)
 I $G(PPPERR1)=1 K PPPERR1 G FAC
 S PPPIEN=$S($G(PPPIEN)'="":PPPIEN,1:PPPSITE)
 S:$G(DMNNAME)="" DMNNAME=""
 S LNUM=0 I $G(DMNNAME)]"" S LNUM=$O(^PPP(1020.128,"A",DMNNAME,0))
 I LNUM S DMNNAME=$P(^PPP(1020.128,LNUM,0),"^",2),DMNNEW=$G(DMNNEW)+1
 ;
UPDATE ;new entry or update old
 S X=@MPDARR@(PPPSSN,"SITES",PPPSITE),%DT="" D ^%DT S LSTVISIT=Y K X,UPDATE1
 I $G(DMNNAME)'="",$D(^PPP(1020.2,"AC",PATDFN,DMNNAME)) S PPPIEN1=$O(^PPP(1020.2,"AC",PATDFN,DMNNAME,0)) D
 .Q:$G(PPPIEN1)'>0
 .S OLDDT=$P($G(^PPP(1020.2,PPPIEN1,0)),"^",3) ;Date of last visit
 .I LSTVISIT>OLDDT S DIE="^PPP(1020.2,",DA=PPPIEN1,DR="2///"_LSTVISIT D ^DIE K DR,DIE
 .S UPDATE1=1 Q
 I $G(UPDATE1)=1 G FAC ;get next facility visited
NEWSSN ;
 S X=PATDFN,DIC="^PPP(1020.2,",DIC(0)="",DIC("DR")="1////"_PPPIEN_";2///"_LSTVISIT_";7///0" K DD,D0 D FILE^DICN
 G FAC
 ;
FINI ;Done
 G ^PPPBFFX2
Q D Q^PPPBFFX K ^TMP($J) Q
 S X=0 F  S X=$O(@KLLARRAY@(X)) Q:X=""  K @KLLARRAY@(X)
 K X,KLLARRAY Q
TXT S ERRTXT=$G(ERRTXT)+1 Q
NXTBTCH S X=0 F  S X=$O(@SSNARR@(X)) Q:X=""  K @SSNARR@(X)
 S X=0 F  S X=$O(@MPDARR@(X)) Q:X=""  K @MPDARR@(X),@MPDARR@("DONE",X)
 S CNTR2=0
 G 2