ECXDENT ;ALB/JAP,BIR/DMA,PTD-Dental Extract for DSS ; [ 11/22/96 5:23 PM ]
;;3.0;DSS EXTRACTS;**11,8,13,24,33,39,46**;Dec 22, 1997
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ;start package specific extract
N DATA,X,Y
K ECXDD D FIELD^DID(220.5,.01,,"SPECIFIER","ECXDD")
S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
S ECED=ECED+.3,ECD=ECSD1,QFLG=0
F S ECD=$O(^DENT(221,"B",ECD)),ECXJ=0 Q:('ECD)!(ECD>ECED)!(QFLG) D
.F S ECXJ=$O(^DENT(221,"B",ECD,ECXJ)) Q:'ECXJ D Q:QFLG
..Q:'$D(^DENT(221,ECXJ,0))
..S DATA=^DENT(221,ECXJ,0),$P(DATA,U,50)="" D STUFF
Q
STUFF ;get data
K ECXPAT
S ECXDFN=+$P(DATA,U,4),OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.ECXPAT)
Q:'OK
S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
S X=$$INP^ECXUTL2(ECXDFN,ECD),ECXA=$P(X,U),ECXMN=$P(X,U,2)
S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4)
S ECDEN=$P(DATA,U,3),ECDEN=$P($G(^DENT(220.5,ECDEN,0)),U)
S:ECDEN]"" ECDEN=ECPRO_ECDEN S ECDENNPI=""
S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECD,"."),ECPRO)
S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
;use of dss department delayed S ECXDSSD=$$DEN^ECXDEPT($P(DATA,U,40))
S ECXDSSD=""
;
;- Observation patient indicator (YES/NO)
S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
;
;- If no encounter number don't file record
S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$P(DATA,U),ECXTS,ECXOBS,ECHEAD,,)
D:ECXENC'="" FILE
Q
;
FILE ;file record
;node0
;inst^dfn^ssn^name^in/out ECXA^day^provider^screen/complete^admin proc^
;x-rays ex^x-rays int^prophy natural^prophy denture^op room^
;neoplasm malig^
;neoplasm removed^biopsy/smear^fracture^pat category^other sig surg^
;surface restored^root canal^periodontal quads (surg)^
;perio quads (root plane)^
;patient ed^spot check exam^indiv crowns^posts & cores^
;fixed partials (abut)^fixed partials (pont)^removable partials^
;complete dentures^prosthetic repair^
;splints & spec procs^extractions^surg extractions^other sig treatment^
;div^completion/termination^interdisc consult^evaluation^
;pre-auth 2nd opinion^
;spot check discrepancy^mov #^treat spec^primary care team^
;primary care provider^time
;node1
;mpi^dss dept^provider npi^pc provider npi^pc prov person class^
;assoc pc prov^assoc pc prov person class^assoc pc prov npi^
;dom ECXDOM^observ pat ind ECXOBS^encounter num ECXENC^
;production division
;
N DA,DIK
S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
S ECODE=EC7_U_EC23_U
S ECODE=ECODE_$P(DATA,U,40)_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
S ECODE=ECODE_$$ECXDATE^ECXUTL($P(DATA,U),ECXYM)_U_ECDEN_U
S ECODE=ECODE_$P(DATA,U,7,9)_U_$P(DATA,U,11,20)_U_$P(DATA,U,22,38)_U
S ECODE=ECODE_$P(DATA,U,40,45)_U_ECXMN_U_ECXTS_U
S ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL($P(DATA,U))_U
S ECODE1=ECXMPI_U_ECXDSSD_U_ECDENNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U
S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_$P(DATA,U,40) ;p-46 added U_$P(DATA,U,40)
S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
Q
;
SETUP ;Set required input for ECXTRAC
S ECHEAD="DEN"
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
Q
;
QUE ; entry point for the background requeuing handled by ECXTAUTO
D SETUP,QUE^ECXTAUTO,^ECXKILL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXDENT 3506 printed Apr 09, 2024@20:55:58 Page 2
ECXDENT ;ALB/JAP,BIR/DMA,PTD-Dental Extract for DSS ; [ 11/22/96 5:23 PM ]
+1 ;;3.0;DSS EXTRACTS;**11,8,13,24,33,39,46**;Dec 22, 1997
BEG ;entry point from option
+1 DO SETUP
IF ECFILE=""
QUIT
+2 DO ^ECXTRAC
DO ^ECXKILL
+3 QUIT
+4 ;
START ;start package specific extract
+1 NEW DATA,X,Y
+2 KILL ECXDD
DO FIELD^DID(220.5,.01,,"SPECIFIER","ECXDD")
+3 SET ECPRO=$EXTRACT(+$PIECE(ECXDD("SPECIFIER"),"P",2))
KILL ECXDD
+4 SET ECED=ECED+.3
SET ECD=ECSD1
SET QFLG=0
+5 FOR
SET ECD=$ORDER(^DENT(221,"B",ECD))
SET ECXJ=0
if ('ECD)!(ECD>ECED)!(QFLG)
QUIT
Begin DoDot:1
+6 FOR
SET ECXJ=$ORDER(^DENT(221,"B",ECD,ECXJ))
if 'ECXJ
QUIT
Begin DoDot:2
+7 if '$DATA(^DENT(221,ECXJ,0))
QUIT
+8 SET DATA=^DENT(221,ECXJ,0)
SET $PIECE(DATA,U,50)=""
DO STUFF
End DoDot:2
if QFLG
QUIT
End DoDot:1
+9 QUIT
STUFF ;get data
+1 KILL ECXPAT
+2 SET ECXDFN=+$PIECE(DATA,U,4)
SET OK=$$PAT^ECXUTL3(ECXDFN,$PIECE(ECD,"."),"1;",.ECXPAT)
+3 if 'OK
QUIT
+4 SET ECXPNM=ECXPAT("NAME")
SET ECXSSN=ECXPAT("SSN")
SET ECXMPI=ECXPAT("MPI")
+5 SET X=$$INP^ECXUTL2(ECXDFN,ECD)
SET ECXA=$PIECE(X,U)
SET ECXMN=$PIECE(X,U,2)
+6 SET ECXTS=$PIECE(X,U,3)
SET ECXDOM=$PIECE(X,U,10)
SET ECXADMDT=$PIECE(X,U,4)
+7 SET ECDEN=$PIECE(DATA,U,3)
SET ECDEN=$PIECE($GET(^DENT(220.5,ECDEN,0)),U)
+8 if ECDEN]""
SET ECDEN=ECPRO_ECDEN
SET ECDENNPI=""
+9 SET X=$$PRIMARY^ECXUTL2(ECXDFN,$PIECE(ECD,"."),ECPRO)
+10 SET ECPTTM=$PIECE(X,U,1)
SET ECPTPR=$PIECE(X,U,2)
SET ECCLAS=$PIECE(X,U,3)
SET ECPTNPI=$PIECE(X,U,4)
+11 SET ECASPR=$PIECE(X,U,5)
SET ECCLAS2=$PIECE(X,U,6)
SET ECASNPI=$PIECE(X,U,7)
+12 ;use of dss department delayed S ECXDSSD=$$DEN^ECXDEPT($P(DATA,U,40))
+13 SET ECXDSSD=""
+14 ;
+15 ;- Observation patient indicator (YES/NO)
+16 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+17 ;
+18 ;- If no encounter number don't file record
+19 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$PIECE(DATA,U),ECXTS,ECXOBS,ECHEAD,,)
+20 if ECXENC'=""
DO FILE
+21 QUIT
+22 ;
FILE ;file record
+1 ;node0
+2 ;inst^dfn^ssn^name^in/out ECXA^day^provider^screen/complete^admin proc^
+3 ;x-rays ex^x-rays int^prophy natural^prophy denture^op room^
+4 ;neoplasm malig^
+5 ;neoplasm removed^biopsy/smear^fracture^pat category^other sig surg^
+6 ;surface restored^root canal^periodontal quads (surg)^
+7 ;perio quads (root plane)^
+8 ;patient ed^spot check exam^indiv crowns^posts & cores^
+9 ;fixed partials (abut)^fixed partials (pont)^removable partials^
+10 ;complete dentures^prosthetic repair^
+11 ;splints & spec procs^extractions^surg extractions^other sig treatment^
+12 ;div^completion/termination^interdisc consult^evaluation^
+13 ;pre-auth 2nd opinion^
+14 ;spot check discrepancy^mov #^treat spec^primary care team^
+15 ;primary care provider^time
+16 ;node1
+17 ;mpi^dss dept^provider npi^pc provider npi^pc prov person class^
+18 ;assoc pc prov^assoc pc prov person class^assoc pc prov npi^
+19 ;dom ECXDOM^observ pat ind ECXOBS^encounter num ECXENC^
+20 ;production division
+21 ;
+22 NEW DA,DIK
+23 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+24 SET ECODE=EC7_U_EC23_U
+25 SET ECODE=ECODE_$PIECE(DATA,U,40)_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+26 SET ECODE=ECODE_$$ECXDATE^ECXUTL($PIECE(DATA,U),ECXYM)_U_ECDEN_U
+27 SET ECODE=ECODE_$PIECE(DATA,U,7,9)_U_$PIECE(DATA,U,11,20)_U_$PIECE(DATA,U,22,38)_U
+28 SET ECODE=ECODE_$PIECE(DATA,U,40,45)_U_ECXMN_U_ECXTS_U
+29 SET ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL($PIECE(DATA,U))_U
+30 SET ECODE1=ECXMPI_U_ECXDSSD_U_ECDENNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U
+31 ;p-46 added U_$P(DATA,U,40)
SET ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_$PIECE(DATA,U,40)
+32 SET ^ECX(ECFILE,EC7,0)=ECODE
SET ^ECX(ECFILE,EC7,1)=ECODE1
SET ECRN=ECRN+1
+33 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX1^DIK
KILL DIK,DA
+34 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET QFLG=1
+35 QUIT
+36 ;
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="DEN"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 QUIT
+4 ;
QUE ; entry point for the background requeuing handled by ECXTAUTO
+1 DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
QUIT
