DG53213P ;BP-CIOFO/KEITH - NPCDB patient demographics extraction utility ; 07 Dec 98 12:05 PM
;;5.3;Registration;**213**;AUG 13, 1993
;
NOQ ;Suppress option question
S:$G(XPDENV)=1 XPDDIQ("XPZ1")=0 Q
;
RUN ;Exit if XTMP global exists
N X F X=1:1:10 L ^XTMP("DG53213P",0):1 Q:$T
I '$T D BMES^XPDUTL("Unable to lock global try later!") Q
I $D(^XTMP("DG53213P",0)),$$ZQ() G LQ
;
BQ ;Queue extraction global build process
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,DGI,Y,%,%H,%I
S ZTRTN="BUILD^DG53213P",ZTDESC="NPCDB patient demographics extraction"
D NOW^%DTC S (DGQDT,ZTDTH)=XPDQUES("POS1"),ZTIO=""
F DGI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
I '$G(ZTSK) D BMES^XPDUTL("Unable to queue extraction, contact Customer Service for assistance!") G LQ
S Y=DGQDT X ^DD("DD")
N X1,X2,DGPDT K ^XTMP("DG53213P")
S X1=DT,X2=30 D C^%DTC S DGPDT=X
S ^XTMP("DG53213P",0)=DGPDT_U_DT_"^Patch DG*5.3*213 NPCDB patient demographics extraction global. Created by user: "_DUZ
S ^XTMP("DG53213P",1,"QUEUED")=DGQDT_U_ZTSK
D BMES^XPDUTL("NPCDB patient demographics extraction queued for "_$P(Y,":",1,2))
D BMES^XPDUTL("Task number: "_ZTSK)
LQ L -^XTMP("DG53213P")
Q
;
ZQ() ;Determine if process is already queued
N ZTSK S ZTSK=+$P($G(^XTMP("DG53213P",1,"QUEUED")),U,2) Q:'ZTSK 0
D STAT^%ZTLOAD Q:'ZTSK(0) 0 Q:"0345"[ZTSK(1) 0
D BMES^XPDUTL("Patient demographics extraction not queued--")
D BMES^XPDUTL("It appears that this process is already in progress!")
Q 1
;
BUILD ;Build XTMP global with list of records to send
S (DGFS,DGOUT)=0 F DGI="COUNT","SENT" S ^XTMP("DG53213P",1,DGI)=0
;
;Get patient list
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN!DGOUT D
.I DFN#500=0 D STOP Q:DGOUT
.I $L($P($G(^DPT(DFN,.1)),U)) D SET("CI") Q ;Current inpatient
.I $O(^DGPM("APTT3",DFN,""),-1)>2981001 D SET("DC") Q ;Discharged this Fiscal Year
.I $$OUTPTPR^SDUTL3(DFN) D SET("PC") Q ;Assigned to PC provider
.Q
;
I DGOUT S DGFS=1 K ^XTMP("DG53213P",2) D REQUE("BUILD^DG53213P"),MSG Q
;
S ^XTMP("DG53213P",1,"GROUP")=^XTMP("DG53213P",1,"COUNT")\7+1
;
SEND ;Send group of patient records to NPCDB
S (DGOUT,DGFS)=0,DGGP=^XTMP("DG53213P",1,"GROUP")
S (DGCT,DGERR,DFN)=0
F S DFN=$O(^XTMP("DG53213P",2,DFN)) Q:DGCT>DGGP!'DFN!DGOUT D S1
I 'DGOUT,DGCT<DGGP,$D(^XTMP("DG53213P",2)) G SEND
S ^XTMP("DG53213P",1,"SENT")=^XTMP("DG53213P",1,"SENT")+DGCT
I $$DONE() D MSG K ^XTMP("DG53213P") Q
D REQUE("SEND^DG53213P"),MSG Q
;
REQUE(ZTRTN) ;Requeue for tomorrow's run
;Required input: ZTRTN=routine to queue
N ZTDESC,ZTIO,X,Y,%,%H,%I,X1,X2,X
S %H=ZTDTH D YX^%DTC S ZTDTH=X_%
S ZTDESC="NPCDB patient demographics extraction"
S X1=ZTDTH,X2=1 D C^%DTC S (DGQDT,ZTDTH)=X,ZTIO=""
F DGI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
I $G(ZTSK) S ^XTMP("DG53213P",1,"QUEUED")=DGQDT_U_ZTSK
S:'$G(ZTSK) DGERR=1
Q
;
MSG ;Send mail message
N XMSUB,XMDUZ,XMDUN,XMTEXT,XMY,XMZ,DG,DA,DIE,DR
BMSG S XMSUB="NPCDB patient demographics extraction",DGERR=$G(DGERR,0)
S (XMDUZ,XMDUN)="Patch DG*5.3*213"
D M1 S XMTEXT="DG(",XMY(DUZ)="" D ^XMD
;
CLEAN K DGFS,DGOUT,DGQDT,DGERR,DGI,DFN,DGCT,DGGP,DGPV Q
;
M1 ;Message text
S DGI=0 I '$$DONE() S Y=DGQDT X ^DD("DD")
D TXT(" *** Status of NPCDB patient demographics extraction ***"),TXT(" ")
I $$DONE(),'DGFS D TXT(" NPCDB patient demographics extraction completed!"),TXT(" ")
I DGERR D TXT("Unable to queue NPCDB patient demographics extraction continuation--"),TXT("Please contact Customer Service for assistance!"),TXT(" ")
D:'DGFS TXT(" Number of records found to send: "_^XTMP("DG53213P",1,"COUNT"))
D:'DGFS TXT("Number of records that have been sent: "_^XTMP("DG53213P",1,"SENT"))
D:DGFS TXT("Extraction process was requested to stop before building a complete list.")
D:DGFS TXT("The partially built list was cleared, extraction will be restarted as follows:")
D TXT(" ")
I '$$DONE()!DGFS,'DGERR D
.D:DGFS TXT(" NPCDB extraction queued for: "_Y)
.D:'DGFS TXT(" Next transmission queued for: "_Y)
.D TXT(" Task number: "_ZTSK)
.Q
I $$DONE(),$D(^XTMP("DG53213P",4)) D
.D TXT("Unable to send these records:")
.S DFN=0 F S DFN=$O(^XTMP("DG53213P",4)) Q:'DFN D
..D TXT("IFN: "_DFN_" NAME: "_$P($G(^DPT(DFN,0),"UNKNOWN"),U))
..Q
.Q
Q
;
TXT(DGT) ;Build message line
;Required input: DGT=line of text
S DGI=DGI+1,DG(DGI)=DGT Q
;
DONE() ;Determine if extraction is finished
Q '$D(^XTMP("DG53213P",2))
;
S1 ;Send a record
I DGCT#100=0 D STOP Q:DGOUT
S DGPV=$$PIVNW^VAFHPIVT(DFN,$$NOW^XLFDT(),4,DFN_";DPT(")
I 'DGPV D Q
.S ^XTMP("DG53213P",2,DFN)=^XTMP("DG53213P",2,DFN)+1
.Q:^XTMP("DG53213P",2,DFN)<3
.S ^XTMP("DG53213P",4,DFN)=""
.K ^XTMP("DG53213P",2,DFN) Q
D XMITFLAG^VAFCDD01(,DGPV)
S ^XTMP("DG53213P",3,DFN)=DGPV,DGCT=DGCT+1
K ^XTMP("DG53213P",2,DFN)
Q
;
SET(DGR) ;Set patient list node
;Required input: DGR=reason for inclusion
S ^XTMP("DG53213P",2,DFN)=DGR
S ^XTMP("DG53213P",1,"COUNT")=^XTMP("DG53213P",1,"COUNT")+1
Q
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (DGOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53213P 5160 printed Apr 09, 2024@21:49:02 Page 2
DG53213P ;BP-CIOFO/KEITH - NPCDB patient demographics extraction utility ; 07 Dec 98 12:05 PM
+1 ;;5.3;Registration;**213**;AUG 13, 1993
+2 ;
NOQ ;Suppress option question
+1 if $GET(XPDENV)=1
SET XPDDIQ("XPZ1")=0
QUIT
+2 ;
RUN ;Exit if XTMP global exists
+1 NEW X
FOR X=1:1:10
LOCK ^XTMP("DG53213P",0):1
if $TEST
QUIT
+2 IF '$TEST
DO BMES^XPDUTL("Unable to lock global try later!")
QUIT
+3 IF $DATA(^XTMP("DG53213P",0))
IF $$ZQ()
GOTO LQ
+4 ;
BQ ;Queue extraction global build process
+1 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,DGI,Y,%,%H,%I
+2 SET ZTRTN="BUILD^DG53213P"
SET ZTDESC="NPCDB patient demographics extraction"
+3 DO NOW^%DTC
SET (DGQDT,ZTDTH)=XPDQUES("POS1")
SET ZTIO=""
+4 FOR DGI=1:1:20
DO ^%ZTLOAD
if $GET(ZTSK)
QUIT
+5 IF '$GET(ZTSK)
DO BMES^XPDUTL("Unable to queue extraction, contact Customer Service for assistance!")
GOTO LQ
+6 SET Y=DGQDT
XECUTE ^DD("DD")
+7 NEW X1,X2,DGPDT
KILL ^XTMP("DG53213P")
+8 SET X1=DT
SET X2=30
DO C^%DTC
SET DGPDT=X
+9 SET ^XTMP("DG53213P",0)=DGPDT_U_DT_"^Patch DG*5.3*213 NPCDB patient demographics extraction global. Created by user: "_DUZ
+10 SET ^XTMP("DG53213P",1,"QUEUED")=DGQDT_U_ZTSK
+11 DO BMES^XPDUTL("NPCDB patient demographics extraction queued for "_$PIECE(Y,":",1,2))
+12 DO BMES^XPDUTL("Task number: "_ZTSK)
LQ LOCK -^XTMP("DG53213P")
+1 QUIT
+2 ;
ZQ() ;Determine if process is already queued
+1 NEW ZTSK
SET ZTSK=+$PIECE($GET(^XTMP("DG53213P",1,"QUEUED")),U,2)
if 'ZTSK
QUIT 0
+2 DO STAT^%ZTLOAD
if 'ZTSK(0)
QUIT 0
if "0345"[ZTSK(1)
QUIT 0
+3 DO BMES^XPDUTL("Patient demographics extraction not queued--")
+4 DO BMES^XPDUTL("It appears that this process is already in progress!")
+5 QUIT 1
+6 ;
BUILD ;Build XTMP global with list of records to send
+1 SET (DGFS,DGOUT)=0
FOR DGI="COUNT","SENT"
SET ^XTMP("DG53213P",1,DGI)=0
+2 ;
+3 ;Get patient list
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN!DGOUT
QUIT
Begin DoDot:1
+5 IF DFN#500=0
DO STOP
if DGOUT
QUIT
+6 ;Current inpatient
IF $LENGTH($PIECE($GET(^DPT(DFN,.1)),U))
DO SET("CI")
QUIT
+7 ;Discharged this Fiscal Year
IF $ORDER(^DGPM("APTT3",DFN,""),-1)>2981001
DO SET("DC")
QUIT
+8 ;Assigned to PC provider
IF $$OUTPTPR^SDUTL3(DFN)
DO SET("PC")
QUIT
+9 QUIT
End DoDot:1
+10 ;
+11 IF DGOUT
SET DGFS=1
KILL ^XTMP("DG53213P",2)
DO REQUE("BUILD^DG53213P")
DO MSG
QUIT
+12 ;
+13 SET ^XTMP("DG53213P",1,"GROUP")=^XTMP("DG53213P",1,"COUNT")\7+1
+14 ;
SEND ;Send group of patient records to NPCDB
+1 SET (DGOUT,DGFS)=0
SET DGGP=^XTMP("DG53213P",1,"GROUP")
+2 SET (DGCT,DGERR,DFN)=0
+3 FOR
SET DFN=$ORDER(^XTMP("DG53213P",2,DFN))
if DGCT>DGGP!'DFN!DGOUT
QUIT
DO S1
+4 IF 'DGOUT
IF DGCT<DGGP
IF $DATA(^XTMP("DG53213P",2))
GOTO SEND
+5 SET ^XTMP("DG53213P",1,"SENT")=^XTMP("DG53213P",1,"SENT")+DGCT
+6 IF $$DONE()
DO MSG
KILL ^XTMP("DG53213P")
QUIT
+7 DO REQUE("SEND^DG53213P")
DO MSG
QUIT
+8 ;
REQUE(ZTRTN) ;Requeue for tomorrow's run
+1 ;Required input: ZTRTN=routine to queue
+2 NEW ZTDESC,ZTIO,X,Y,%,%H,%I,X1,X2,X
+3 SET %H=ZTDTH
DO YX^%DTC
SET ZTDTH=X_%
+4 SET ZTDESC="NPCDB patient demographics extraction"
+5 SET X1=ZTDTH
SET X2=1
DO C^%DTC
SET (DGQDT,ZTDTH)=X
SET ZTIO=""
+6 FOR DGI=1:1:20
DO ^%ZTLOAD
if $GET(ZTSK)
QUIT
+7 IF $GET(ZTSK)
SET ^XTMP("DG53213P",1,"QUEUED")=DGQDT_U_ZTSK
+8 if '$GET(ZTSK)
SET DGERR=1
+9 QUIT
+10 ;
MSG ;Send mail message
+1 NEW XMSUB,XMDUZ,XMDUN,XMTEXT,XMY,XMZ,DG,DA,DIE,DR
BMSG SET XMSUB="NPCDB patient demographics extraction"
SET DGERR=$GET(DGERR,0)
+1 SET (XMDUZ,XMDUN)="Patch DG*5.3*213"
+2 DO M1
SET XMTEXT="DG("
SET XMY(DUZ)=""
DO ^XMD
+3 ;
CLEAN KILL DGFS,DGOUT,DGQDT,DGERR,DGI,DFN,DGCT,DGGP,DGPV
QUIT
+1 ;
M1 ;Message text
+1 SET DGI=0
IF '$$DONE()
SET Y=DGQDT
XECUTE ^DD("DD")
+2 DO TXT(" *** Status of NPCDB patient demographics extraction ***")
DO TXT(" ")
+3 IF $$DONE()
IF 'DGFS
DO TXT(" NPCDB patient demographics extraction completed!")
DO TXT(" ")
+4 IF DGERR
DO TXT("Unable to queue NPCDB patient demographics extraction continuation--")
DO TXT("Please contact Customer Service for assistance!")
DO TXT(" ")
+5 if 'DGFS
DO TXT(" Number of records found to send: "_^XTMP("DG53213P",1,"COUNT"))
+6 if 'DGFS
DO TXT("Number of records that have been sent: "_^XTMP("DG53213P",1,"SENT"))
+7 if DGFS
DO TXT("Extraction process was requested to stop before building a complete list.")
+8 if DGFS
DO TXT("The partially built list was cleared, extraction will be restarted as follows:")
+9 DO TXT(" ")
+10 IF '$$DONE()!DGFS
IF 'DGERR
Begin DoDot:1
+11 if DGFS
DO TXT(" NPCDB extraction queued for: "_Y)
+12 if 'DGFS
DO TXT(" Next transmission queued for: "_Y)
+13 DO TXT(" Task number: "_ZTSK)
+14 QUIT
End DoDot:1
+15 IF $$DONE()
IF $DATA(^XTMP("DG53213P",4))
Begin DoDot:1
+16 DO TXT("Unable to send these records:")
+17 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("DG53213P",4))
if 'DFN
QUIT
Begin DoDot:2
+18 DO TXT("IFN: "_DFN_" NAME: "_$PIECE($GET(^DPT(DFN,0),"UNKNOWN"),U))
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
TXT(DGT) ;Build message line
+1 ;Required input: DGT=line of text
+2 SET DGI=DGI+1
SET DG(DGI)=DGT
QUIT
+3 ;
DONE() ;Determine if extraction is finished
+1 QUIT '$DATA(^XTMP("DG53213P",2))
+2 ;
S1 ;Send a record
+1 IF DGCT#100=0
DO STOP
if DGOUT
QUIT
+2 SET DGPV=$$PIVNW^VAFHPIVT(DFN,$$NOW^XLFDT(),4,DFN_";DPT(")
+3 IF 'DGPV
Begin DoDot:1
+4 SET ^XTMP("DG53213P",2,DFN)=^XTMP("DG53213P",2,DFN)+1
+5 if ^XTMP("DG53213P",2,DFN)<3
QUIT
+6 SET ^XTMP("DG53213P",4,DFN)=""
+7 KILL ^XTMP("DG53213P",2,DFN)
QUIT
End DoDot:1
QUIT
+8 DO XMITFLAG^VAFCDD01(,DGPV)
+9 SET ^XTMP("DG53213P",3,DFN)=DGPV
SET DGCT=DGCT+1
+10 KILL ^XTMP("DG53213P",2,DFN)
+11 QUIT
+12 ;
SET(DGR) ;Set patient list node
+1 ;Required input: DGR=reason for inclusion
+2 SET ^XTMP("DG53213P",2,DFN)=DGR
+3 SET ^XTMP("DG53213P",1,"COUNT")=^XTMP("DG53213P",1,"COUNT")+1
+4 QUIT
+5 ;
STOP ;Check for stop task request
+1 if $DATA(ZTQUEUED)
SET (DGOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
