source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPIVD.m@ 1046

Last change on this file since 1046 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1ECXPIVD ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV STATS File (#50.8) ; [ 12/05/96 10:41 AM ]
2 ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33**;Dec 22, 1997
3BEG ;entry point from option
4 D SETUP I ECFILE="" Q
5 D ^ECXTRAC,^ECXKILL
6 Q
7 ;
8START ; start package specific extract
9 N X
10 S QFLG=0
11 S ECED=ECED+.3
12 K ^TMP($J)
13 S ECIV=0 F S ECIV=$O(^PS(50.8,ECIV)),ECD=ECSD1 Q:'ECIV F S ECD=$O(^PS(50.8,ECIV,2,ECD)) Q:'ECD Q:ECD>ECED K ^TMP($J) D Q:QFLG
14 .;go thru AC crossreference to get pointers to 52.6 and 52.7
15 .F ECJ=52.6,52.7 S ECK=0 F S ECK=$O(^PS(50.8,ECIV,2,ECD,2,"AC",ECJ,ECK)),ECL=0 Q:'ECK F S ECL=$O(^PS(50.8,ECIV,2,ECD,2,"AC",ECJ,ECK,ECL)) Q:'ECL S ^TMP($J,ECL,ECK)=""
16 .S ECI=0 F S ECI=$O(^PS(50.8,ECIV,2,ECD,2,ECI)) Q:'ECI I $D(^(ECI,0)) S ECC=$P(^(0),U,5),ECF=+$P(^(0),U,7),ECDRG=+$O(^TMP($J,ECI,0)),EC50=+$P($G(^PS(ECF,ECDRG,0)),U,2) D Q:QFLG
17 ..S ECCAT=$P($G(^PSDRUG(EC50,0)),U,2),ECNDC=$P($G(^(2)),U,4),ECNDF=$G(^("ND")),ECINV=$P(^(0),U,3),ECINV=$S(ECINV["I":"I",1:"")
18 ..S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0)
19 ..S P1=$P(ECNDF,U),P3=$P(ECNDF,U,3)
20 ..S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
21 ..I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
22 ..S ECDFN=0 F S ECDFN=$O(^PS(50.8,ECIV,2,ECD,2,ECI,1,ECDFN)) Q:'ECDFN I $D(^(ECDFN,0)) S EC=^(0),ECQ=$P(EC,U,2)-$P(EC,U,3)-$P(EC,U,6),ECCS=ECQ*ECC,ECW=$P(EC,U,5) I ECQ D Q:QFLG
23 ...I $D(^DPT(ECDFN,0)) S EC1=^(0),(ECWD,ECMN,ECTS,ECADM,ECXDSSI,ECXDSSD)="" D
24 ....K ECXPAT S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT)
25 ....Q:'OK
26 ....S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
27 ....S X=$$PRIMARY^ECXUTL2(ECDFN,$P(ECD,"."))
28 ....S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
29 ....I ECW=.5 S ECWD="CLI"
30 ....I ECW<.5 S ECWD=$P($G(^DIC(42,+ECW,44)),U)
31 ....S X=$$INP^ECXUTL2(DFN,ECD),ECXA=$P(X,U),ECMN=$P(X,U,2)
32 ....S ECTS=$P(X,U,3),ECADM=$P(X,U,4),ECXDOM=$P(X,U,10)
33 ....D FILE K P1,P3
34 Q
35 ;
36FILE ;file record
37 ;node0
38 ;fac^dfn^ssn^name^i/o (ECXA)^day^va class^qty^ward^
39 ;cost^movement #^treat spec^ndc^investigational^
40 ;iv dispensing fee^new feeder key^total doses^
41 ;primary care team^primary care provider^
42 ;ivp time^adm date^adm time^dss identifier
43 ;node1
44 ;mpi^dss dept^pc provider npi^pc prov person class^assoc pc provider^
45 ;assoc pc prov person class^assoc pc prov npi^dom^extended outpatient
46 N DA,DIK
47 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
48 S ECODE=EC7_U_EC23_U_ECINST_U_ECDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
49 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECCAT_U_ECQ_U
50 S ECODE=ECODE_ECWD_U_ECCS_U_ECMN_U_ECTS_U_ECNDC_U
51 S ECODE=ECODE_ECINV_U_U_U_U_U
52 S ECODE=ECODE_ECPTTM_U_ECPTPR_U_"000000"_U
53 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECADM,ECXYM)_U_$$ECXTIME^ECXUTL(ECADM)_U
54 S ECODE=ECODE_ECXDSSI_U
55 ;if this is an outpatient, send null for admission date and
56 ; "000000" for admission time
57 I ECW=.5 S $P(ECODE,U,24)="",$P(ECODE,U,25)="000000"
58 S ECODE1=ECXMPI_U_ECXDSSD_U_ECPTNPI_U_ECCLAS_U_ECASPR_U_ECCLAS2_U
59 S ECODE1=ECODE1_ECASNPI_U_ECXDOM_U_$G(ECXEOI)
60 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
61 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
62 I $D(ZTQUEUED),ECRN>499,'(ECRN#500),$$S^%ZTLOAD S QFLG=1
63 Q
64 ;
65SETUP ;Set required input for ECXTRAC
66 S ECHEAD="IVP"
67 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
68 ;variables ecver and ecrtn will be reset in routine ecxtrac
69 ; if appropriate
70 S ECVER=3
71 Q
72 ;
73QUE ; entry point for the background requeuing handled by ECXTAUTO
74 D SETUP,QUE^ECXTAUTO,^ECXKILL Q
Note: See TracBrowser for help on using the repository browser.