- 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 Feb 19, 2025@00:02:45 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