DGPTFTR ;ALB/JDS,HIOFO/FT - TRANSMISSION OF PTF ;8/20/15 3:47pm
;;5.3;Registration;**37,415,530,601,614,645,787,850,884,1134**;Aug 13, 1993;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;
; VA(200) - #10060
; XMB(3.9) - #10113
; VATRAN - #1011
; XLFDT - #10103
; XMA21 - #10067
; XMD - #10070
; %ZTLOAD - #10063
;
ENN ;PTF Transmission [DG PTF TRANSMISSION VADATS]
L +^DGP(45.83):$G(DILOCKTM,5) I '$T W !,"Another user is already transmitting. Please try again later." Q ;45.83 is PTF RELEASE
D CEN^DGPTUTL ;find current census (file 45.86). returns DGCN=ien,DGCN0=zero node
I '$D(DGRTY) S Y=1 D RTY^DGPTUTL ;determine record type. If Y=1, then DGRTY=1,DGRTY0="PTF". If Y=2, then DGRTY=2,DGRTY0="CENSUS"
D FDT^DGPTUTL S DGFMTDT=Y ;sets Y=2901000
;
EN5 ;select a PTF RELEASE date or range
K DIC S DIC=45.83,DIC(0)="AZEQ",DIC("A")="Enter Start Date: "
S DIC("S")="I $O(^DGP(45.83,+Y,""P"",0)) F DGX=0:0 S DGX=$O(^DGP(45.83,+Y,""P"",DGX)) Q:'DGX I '$P(^DGP(45.83,+Y,""P"",DGX,0),U,2),$D(^DGPT(DGX,0)),$D(^(70)),+^(70)>2901000,$P(^(0),U,11)=+DGRTY Q"
S D="ANT" D IX^DIC G ENQ1:X["^"!(X="")
I Y'>0 W !,"There are no "_$S($G(DGRTY)=2:"CENSUS",1:"PTF")_" records in this date range to transmit." G EN5
S DGSD=+Y(0),DIC(0)="EAZQ",DIC("S")="I Y'<DGSD"_" "_DIC("S"),DIC("A")="Enter Through Date: TODAY// ",D="ANT" D IX^DIC K DIC,D
;
G ENQ1:X["^" S DGED=$S(Y>0:+Y(0),1:DT)
;call VATRAN to get transmission variables
;PTF125 should be an entry in TRANSMISSION ROUTERS (#407.7)
;VATERR returns null if no error. 1 or 2 or 3 if can't process
;returns VAT array. VAT(1) & VAT(2) are receiving users
;VAT("F")=message length (fixed record), VAT("V")=message length (variable record)
S VATNAME="PTF125" D ^VATRAN I VATERR K VATNAME,VATERR,VAT L -^DGP(45.83) G ENQ
S DGFMT=2 D SCAN G:DGOUTX ENQ1
ENQ D SCAN^DGPTFTR3 ;loops thru 45.83 and updates transmission date
ENQ1 L -^DGP(45.83) K DGACNT,DGXM,XMDUN,XMY,DGOUTX,DGSTCNT,DIC,DGX,DGRTY,DGRTY0,DGCN,DGCN0,DGPTFMT,DGFMT,DGFMTDT,DGLOGIC,VAT,VATERR,VATNAME,DGSD,DGED,DGPTSLF
Q
;
SCAN K DGERR
N DGY S DGY=$G(Y) D FMT^DGPTUTL S Y=$G(DGY) ;sets DGPTFMT=1, 2 (ICD9 format) or 3 (ICD10 format)
D LOG S DGCNT=1,DGD=DGSD-.01,DGTR=0,DGID=1
;DGTR=counter for # of messges generated, DGID=counter for DGIDN array (DGIDN(DGID)=XMZ)
;DGCNT=counter for number of lines in MailMan message. Bumped up in DGPTRI* routines
;DGD=release date-.01
; DG*5.3*614 - DGFIRST identifies first record in a batch
N DGFIRST S DGFIRST=1
W !!,"Now transmitting ",$P(DGRTY0,U)," records..."
W !,"Includes records of "
;
DAT ;create a MailMan message, transmit it and move on to process additional PTFs
D:DGCNT>1 XMIT Q:$G(DGPTSLF)>0 ;quit if segment lengths are wrong
S DGD=$O(^DGP(45.83,DGD)) ;first time thru, DGCNT is 1, so XMIT is not executed.
I DGD>0,DGD'>DGED D SETTRAN^DGPTUTL1 Q:DGOUTX ;create MailMan message
I DGD'>0!(DGD>DGED) D BULL^DGPTFTR3 G DATQ ;create/send bulletin
S J=0 G PWR
DATQ Q
;
PWR ;get the PTF record and start processing it
Q:$G(DGPTSLF)>0 ;quit if segment lengths are wrong
D CEN^DGPTUTL ;check if census can be sent
S P=J,J=$O(^DGP(45.83,DGD,"P",J)) G DAT:J'>0,PWR:$P(^(J,0),U,2)
I $D(^DGPT(J,0)),$P(^(0),U,11)'=+DGRTY G PWR
I $P(DGCN0,U,3)>DT,DGRTY=1 D CEN^DGPTFTR3 G PWR:'Y
S Y=$S($D(^DGPT(J,70)):+^(70),1:0) D FMT^DGPTUTL G PWR:DGPTFMT<DGFMT
;LINES^DGPTFVC2 counts number of lines for transmission
S T1=0,T2=9999999,Y=J,X=0 S:DGRTY=2 T2=+DGCN0_".9",T1=+$P(DGCN0,U,5) D LINES^DGPTFVC2 I (DGCNT+X)>VAT("F"),'$G(DGFIRST) S J=P G XMIT
I $G(DGFIRST)=1 S DGFIRST=0
K DICR S DGERR=0,DGSTCNT("P",J)=DGCNT
;^TMP("AEDIT",$J) & ^TMP("AERROR",$J) are set in DGPTAE* routines. Used to validate data
W !,$E($P(^DPT(+^DGPT(J,0),0),U),1,25),?27,"(#",J,")" S X=^DGPT(J,0) Q:'$D(^(0)) S DGNODE=^(0),DGADM=$P(DGNODE,U,2) D
. W " Admitted: ",$TR($$FMTE^XLFDT(DGADM,"5DF")," ","0")," " K ^TMP("AEDIT",$J),^TMP("AERROR",$J) S DGACNT=0
. F DGZ=6,4 W $$GET1^DIQ(45,J_",",DGZ)_" "
. K DGNODE,DGZ Q
I DGRTY=1 D COM
I DGRTY=2 S T2=+DGCN0_".9",T1=+$P(DGCN0,U,5),(PTF,DGCI)=J D COM1
I DGERR D OPEN^DGPTFTR3 ;does cleanup. deletes 45.83 data. kills XMY, removes segments from MailMan message. sends Mailman message to user that record is re-opened.
K ^TMP("AEDIT",$J)
I 'DGERR W ?70," Okay" S DGTR=DGTR+1 G XMIT:DGCNT>VAT("F")
G PWR
Q
;
XMIT ;transmit message with PTF segments
K XMY D ROUTER
S XMZ=DGXMZ,^XMB(3.9,XMZ,2,0)="^3.92A^"_(DGCNT-1)_"^"_(DGCNT-1)_"^"_DT,DGJ=J
S XMDUZ=.5,XMDUN=$P(^VA(200,DUZ,0),U)
S DGPTSLF=0 D CHECK(XMZ) ;are segment lengths correct?
I DGPTSLF>0 Q
D ENT1^XMD ;forward message, don't ask for recipients
W !,"Transmission Queued" S DGIDN(DGID)=XMZ
F DGK=0:0 S DGK=$O(DGSTCNT("P",DGK)) Q:DGK'>0 D REC
S DGFIRST=1
;
;DG*5.3*1134 Reset DGSTCNT array - When multiple emails are generated, the
;email IEN of the earlier email is being overwritten/stored with the latter email
;IEN when REC is called above. DGSTCNT is set/will be reset at PWR+10.
K DGSTCNT("P")
;
K DGK S DGCNT=1,DGID=DGID+1,J=DGJ Q:J'>0 D SETTRAN^DGPTUTL1 G:'DGOUTX PWR
Q
;
REC ;update PTF RECORD multiple in PTF RELEASE (45.83). includes PTF record ien, date transmitted, & message ien
;set PTF STATUS="Transmitted"
S DGSENFLG=""
S DIE="^DGP(45.83,",DA=DGD,DR="10///"_DGK,DR(2,45.831)="1///TODAY;2///"_XMZ D ^DIE K DA,DR,DIE
S DIE="^DGPT(",DR="6///3",DA=DGK D ^DIE K DA,DR,DIE
K DGSENFLG
Q
;
COM S T1=0,T2=9999999 S:'$D(PTF) PTF=J S:PTF'=J PTF=J
COM1 ;called from DGPTC1
;pulls data from PTF (45), PATIENT(2) and PTF CLOSE OUT (45.84). Values are used to build segments and do data validation
F K=0,70,71,101,"401P" S @("DG"_K)=$S($D(^DGPT(J,K)):^(K),1:"")
F K=10,.11,.3,.32,.321,.52,57 S @("DG"_$S(K[".":$E(K,2,99),1:K))=$S($D(^DGP(45.84,J,K)):^(K),$D(^DPT(+^DGPT(J,0),$S(K'=10:K,1:0))):$S(K'=10:^(K),1:^(0)),1:"")
F K=.02,.06 M @("DG"_$S(K[".":$E(K,2,99),1:K))=^DPT(+^DGPT(J,0),K)
;uses different processing routines to build segments and MaiLMan based on record format.
;DGPTFMT=1 is very old record format, perhaps before ICD9 usage (not sure).
;DGPTFMT=2 is ICD9 record format
;DGPTFMT=3 is ICD10 record format
;DGPTR* & DGPTRI* routines and similiar, but record format is different.
D ^DGPTFTR0:DGPTFMT=1,^DGPTR0:DGPTFMT=2,^DGPTRI0:DGPTFMT=3
;
Q ;
L -^DGP(45.83)
F K=0,10,701,"401P",101,11,3,32,41,52,57,70,321,502,702,"02","06" K @("DG"_K)
K DGPICD10,DGCDR,DGT,DIC,DGADM,DGAO,DGDOB,DGHEAD,DGJ,DGK,DGL,DGM,DGNAM,DGNT,DGO,DGSSN,DGSUD,DGSUR,DGTD,DGX,DGXLS,E,ERR,F,G,H,I,K,L,T,W,Z,DGPROC,DGPROCD ;** NOTE: do not kill variables needed by PTF load/edit option!!!
;DGPTFVC1 & DGPTFVC2 do expanded ptf close out edits
;DGPTFVC3 does validation checks for ptf additional questions
I $D(DGERR),DGERR<1 D ^DGPTFVC1 D:'T1 ^DGPTFVC3
I $D(DGERR),DGERR<1 D EN^DGPTFVC2
Q
;
LOG ;called from PRINT+1^DGPTF2,CLS+1^DGPTF2,EN^DGPTFVC
D LOG^DGPTFTR1:DGPTFMT=1,LOG^DGPTR1:DGPTFMT=2,LOG^DGPTRI1:DGPTFMT=3,COM:$D(DGERR) ;note: COM is not called unless DGERR exists
Q
;
;-- check for real queue if census should be removed for national rel
ROUTER ;called from DGPTF099,DGPTRPO
;DGSDI is local or remote address
;I $D(XMDF) then all addressing restrictions are waived
;XMN - Can't find this variable in MailMan documentation. May not do anything.
S XMDUZ=.5 F DGSDI=0:0 S DGSDI=$O(VAT(DGSDI)) Q:'DGSDI S X=VAT(DGSDI),XMN=0,XMDF="" D INST^XMA21 K XMN,XMDF
S XMY(DUZ)=""
Q
;
CHECK(DGPTXMZ) ;check if every two lines in message body equal 384 characters
N DGPTLAST,DGPTLOOP,DGPTNODE,DGPTTEXT,DGPTTOT
S DGPTNODE=$G(^XMB(3.9,DGPTXMZ,2,0))
S DGPTLAST=$P(DGPTNODE,U,4)
F DGPTLOOP=1:2:DGPTLAST D Q:$G(DGPTSLF)=1
.S DGPTTOT=$L($G(^XMB(3.9,DGPTXMZ,2,DGPTLOOP,0)))+$L($G(^XMB(3.9,DGPTXMZ,2,DGPTLOOP+1,0)))
.I DGPTTOT'=384 D
..S DGPTSLF=1 ;segment length flag
..D QMSG(DGPTXMZ)
..W !!,"There is a problem with the segment length of a PTF record."
..W !,"The MailMan message number is "_DGPTXMZ_"."
..W !,"Please log a Remedy ticket. Stopping transmission.",!
Q
;
QMSG(DGPTMIEN) ;notify others about bad segment length
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S ZTDESC="DG PTF TRANSMISSION VADATS",ZTDTH=$$NOW^XLFDT(),ZTIO="",ZTRTN="SMSG^DGPTFTR"
S ZTSAVE("DGPTMIEN")=""
D ^%ZTLOAD
Q
;
SMSG ;send MailMan message
N DGPTTEXT,XMDUZ,XMSUB,XMTEXT,XMY
S XMSUB="Station "_$P($$SITE^VASITE(),U,3)_" has wrong PTF segment length"
S XMDUZ=$S($G(DUZ)>0:$G(DUZ),1:.5)
S DGPTTEXT(1)="The PTF records contained in this message cannot be transmitted"
S DGPTTEXT(2)="to AITC due to format of the content issue."
S DGPTTEXT(3)=" "
S DGPTTEXT(4)="Contact the support help desk and report."
S DGPTTEXT(5)=" "
S DGPTTEXT(6)="Retransmission will need to be attempted once the transmission"
S DGPTTEXT(7)="message format has been corrected."
S DGPTTEXT(8)=" "
S DGPTTEXT(9)="The local MailMan message number is: "_DGPTMIEN
S XMTEXT="DGPTTEXT("
S XMY(DUZ)=""
S XMY("ICD-10OITPTFExpansionTeam@domain.ext")=""
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFTR 9133 printed Sep 23, 2025@20:28:27 Page 2
DGPTFTR ;ALB/JDS,HIOFO/FT - TRANSMISSION OF PTF ;8/20/15 3:47pm
+1 ;;5.3;Registration;**37,415,530,601,614,645,787,850,884,1134**;Aug 13, 1993;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; VA(200) - #10060
+5 ; XMB(3.9) - #10113
+6 ; VATRAN - #1011
+7 ; XLFDT - #10103
+8 ; XMA21 - #10067
+9 ; XMD - #10070
+10 ; %ZTLOAD - #10063
+11 ;
ENN ;PTF Transmission [DG PTF TRANSMISSION VADATS]
+1 ;45.83 is PTF RELEASE
LOCK +^DGP(45.83):$GET(DILOCKTM,5)
IF '$TEST
WRITE !,"Another user is already transmitting. Please try again later."
QUIT
+2 ;find current census (file 45.86). returns DGCN=ien,DGCN0=zero node
DO CEN^DGPTUTL
+3 ;determine record type. If Y=1, then DGRTY=1,DGRTY0="PTF". If Y=2, then DGRTY=2,DGRTY0="CENSUS"
IF '$DATA(DGRTY)
SET Y=1
DO RTY^DGPTUTL
+4 ;sets Y=2901000
DO FDT^DGPTUTL
SET DGFMTDT=Y
+5 ;
EN5 ;select a PTF RELEASE date or range
+1 KILL DIC
SET DIC=45.83
SET DIC(0)="AZEQ"
SET DIC("A")="Enter Start Date: "
+2 SET DIC("S")="I $O(^DGP(45.83,+Y,""P"",0)) F DGX=0:0 S DGX=$O(^DGP(45.83,+Y,""P"",DGX)) Q:'DGX I '$P(^DGP(45.83,+Y,""P"",DGX,0),U,2),$D(^DGPT(DGX,0)),$D(^(70)),+^(70)>2901000,$P(^(0),U,11)=+DGRTY Q"
+3 SET D="ANT"
DO IX^DIC
if X["^"!(X="")
GOTO ENQ1
+4 IF Y'>0
WRITE !,"There are no "_$SELECT($GET(DGRTY)=2:"CENSUS",1:"PTF")_" records in this date range to transmit."
GOTO EN5
+5 SET DGSD=+Y(0)
SET DIC(0)="EAZQ"
SET DIC("S")="I Y'<DGSD"_" "_DIC("S")
SET DIC("A")="Enter Through Date: TODAY// "
SET D="ANT"
DO IX^DIC
KILL DIC,D
+6 ;
+7 if X["^"
GOTO ENQ1
SET DGED=$SELECT(Y>0:+Y(0),1:DT)
+8 ;call VATRAN to get transmission variables
+9 ;PTF125 should be an entry in TRANSMISSION ROUTERS (#407.7)
+10 ;VATERR returns null if no error. 1 or 2 or 3 if can't process
+11 ;returns VAT array. VAT(1) & VAT(2) are receiving users
+12 ;VAT("F")=message length (fixed record), VAT("V")=message length (variable record)
+13 SET VATNAME="PTF125"
DO ^VATRAN
IF VATERR
KILL VATNAME,VATERR,VAT
LOCK -^DGP(45.83)
GOTO ENQ
+14 SET DGFMT=2
DO SCAN
if DGOUTX
GOTO ENQ1
ENQ ;loops thru 45.83 and updates transmission date
DO SCAN^DGPTFTR3
ENQ1 LOCK -^DGP(45.83)
KILL DGACNT,DGXM,XMDUN,XMY,DGOUTX,DGSTCNT,DIC,DGX,DGRTY,DGRTY0,DGCN,DGCN0,DGPTFMT,DGFMT,DGFMTDT,DGLOGIC,VAT,VATERR,VATNAME,DGSD,DGED,DGPTSLF
+1 QUIT
+2 ;
SCAN KILL DGERR
+1 ;sets DGPTFMT=1, 2 (ICD9 format) or 3 (ICD10 format)
NEW DGY
SET DGY=$GET(Y)
DO FMT^DGPTUTL
SET Y=$GET(DGY)
+2 DO LOG
SET DGCNT=1
SET DGD=DGSD-.01
SET DGTR=0
SET DGID=1
+3 ;DGTR=counter for # of messges generated, DGID=counter for DGIDN array (DGIDN(DGID)=XMZ)
+4 ;DGCNT=counter for number of lines in MailMan message. Bumped up in DGPTRI* routines
+5 ;DGD=release date-.01
+6 ; DG*5.3*614 - DGFIRST identifies first record in a batch
+7 NEW DGFIRST
SET DGFIRST=1
+8 WRITE !!,"Now transmitting ",$PIECE(DGRTY0,U)," records..."
+9 WRITE !,"Includes records of "
+10 ;
DAT ;create a MailMan message, transmit it and move on to process additional PTFs
+1 ;quit if segment lengths are wrong
if DGCNT>1
DO XMIT
if $GET(DGPTSLF)>0
QUIT
+2 ;first time thru, DGCNT is 1, so XMIT is not executed.
SET DGD=$ORDER(^DGP(45.83,DGD))
+3 ;create MailMan message
IF DGD>0
IF DGD'>DGED
DO SETTRAN^DGPTUTL1
if DGOUTX
QUIT
+4 ;create/send bulletin
IF DGD'>0!(DGD>DGED)
DO BULL^DGPTFTR3
GOTO DATQ
+5 SET J=0
GOTO PWR
DATQ QUIT
+1 ;
PWR ;get the PTF record and start processing it
+1 ;quit if segment lengths are wrong
if $GET(DGPTSLF)>0
QUIT
+2 ;check if census can be sent
DO CEN^DGPTUTL
+3 SET P=J
SET J=$ORDER(^DGP(45.83,DGD,"P",J))
if J'>0
GOTO DAT
if $PIECE(^(J,0),U,2)
GOTO PWR
+4 IF $DATA(^DGPT(J,0))
IF $PIECE(^(0),U,11)'=+DGRTY
GOTO PWR
+5 IF $PIECE(DGCN0,U,3)>DT
IF DGRTY=1
DO CEN^DGPTFTR3
if 'Y
GOTO PWR
+6 SET Y=$SELECT($DATA(^DGPT(J,70)):+^(70),1:0)
DO FMT^DGPTUTL
if DGPTFMT<DGFMT
GOTO PWR
+7 ;LINES^DGPTFVC2 counts number of lines for transmission
+8 SET T1=0
SET T2=9999999
SET Y=J
SET X=0
if DGRTY=2
SET T2=+DGCN0_".9"
SET T1=+$PIECE(DGCN0,U,5)
DO LINES^DGPTFVC2
IF (DGCNT+X)>VAT("F")
IF '$GET(DGFIRST)
SET J=P
GOTO XMIT
+9 IF $GET(DGFIRST)=1
SET DGFIRST=0
+10 KILL DICR
SET DGERR=0
SET DGSTCNT("P",J)=DGCNT
+11 ;^TMP("AEDIT",$J) & ^TMP("AERROR",$J) are set in DGPTAE* routines. Used to validate data
+12 WRITE !,$EXTRACT($PIECE(^DPT(+^DGPT(J,0),0),U),1,25),?27,"(#",J,")"
SET X=^DGPT(J,0)
if '$DATA(^(0))
QUIT
SET DGNODE=^(0)
SET DGADM=$PIECE(DGNODE,U,2)
Begin DoDot:1
+13 WRITE " Admitted: ",$TRANSLATE($$FMTE^XLFDT(DGADM,"5DF")," ","0")," "
KILL ^TMP("AEDIT",$JOB),^TMP("AERROR",$JOB)
SET DGACNT=0
+14 FOR DGZ=6,4
WRITE $$GET1^DIQ(45,J_",",DGZ)_" "
+15 KILL DGNODE,DGZ
QUIT
End DoDot:1
+16 IF DGRTY=1
DO COM
+17 IF DGRTY=2
SET T2=+DGCN0_".9"
SET T1=+$PIECE(DGCN0,U,5)
SET (PTF,DGCI)=J
DO COM1
+18 ;does cleanup. deletes 45.83 data. kills XMY, removes segments from MailMan message. sends Mailman message to user that record is re-opened.
IF DGERR
DO OPEN^DGPTFTR3
+19 KILL ^TMP("AEDIT",$JOB)
+20 IF 'DGERR
WRITE ?70," Okay"
SET DGTR=DGTR+1
if DGCNT>VAT("F")
GOTO XMIT
+21 GOTO PWR
+22 QUIT
+23 ;
XMIT ;transmit message with PTF segments
+1 KILL XMY
DO ROUTER
+2 SET XMZ=DGXMZ
SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_(DGCNT-1)_"^"_(DGCNT-1)_"^"_DT
SET DGJ=J
+3 SET XMDUZ=.5
SET XMDUN=$PIECE(^VA(200,DUZ,0),U)
+4 ;are segment lengths correct?
SET DGPTSLF=0
DO CHECK(XMZ)
+5 IF DGPTSLF>0
QUIT
+6 ;forward message, don't ask for recipients
DO ENT1^XMD
+7 WRITE !,"Transmission Queued"
SET DGIDN(DGID)=XMZ
+8 FOR DGK=0:0
SET DGK=$ORDER(DGSTCNT("P",DGK))
if DGK'>0
QUIT
DO REC
+9 SET DGFIRST=1
+10 ;
+11 ;DG*5.3*1134 Reset DGSTCNT array - When multiple emails are generated, the
+12 ;email IEN of the earlier email is being overwritten/stored with the latter email
+13 ;IEN when REC is called above. DGSTCNT is set/will be reset at PWR+10.
+14 KILL DGSTCNT("P")
+15 ;
+16 KILL DGK
SET DGCNT=1
SET DGID=DGID+1
SET J=DGJ
if J'>0
QUIT
DO SETTRAN^DGPTUTL1
if 'DGOUTX
GOTO PWR
+17 QUIT
+18 ;
REC ;update PTF RECORD multiple in PTF RELEASE (45.83). includes PTF record ien, date transmitted, & message ien
+1 ;set PTF STATUS="Transmitted"
+2 SET DGSENFLG=""
+3 SET DIE="^DGP(45.83,"
SET DA=DGD
SET DR="10///"_DGK
SET DR(2,45.831)="1///TODAY;2///"_XMZ
DO ^DIE
KILL DA,DR,DIE
+4 SET DIE="^DGPT("
SET DR="6///3"
SET DA=DGK
DO ^DIE
KILL DA,DR,DIE
+5 KILL DGSENFLG
+6 QUIT
+7 ;
COM SET T1=0
SET T2=9999999
if '$DATA(PTF)
SET PTF=J
if PTF'=J
SET PTF=J
COM1 ;called from DGPTC1
+1 ;pulls data from PTF (45), PATIENT(2) and PTF CLOSE OUT (45.84). Values are used to build segments and do data validation
+2 FOR K=0,70,71,101,"401P"
SET @("DG"_K)=$SELECT($DATA(^DGPT(J,K)):^(K),1:"")
+3 FOR K=10,.11,.3,.32,.321,.52,57
SET @("DG"_$SELECT(K[".":$EXTRACT(K,2,99),1:K))=$SELECT($DATA(^DGP(45.84,J,K)):^(K),$DATA(^DPT(+^DGPT(J,0),$SELECT(K'=10:K,1:0))):$SELECT(K'=10:^(K),1:^(0)),1:"")
+4 FOR K=.02,.06
MERGE @("DG"_$SELECT(K[".":$EXTRACT(K,2,99),1:K))=^DPT(+^DGPT(J,0),K)
+5 ;uses different processing routines to build segments and MaiLMan based on record format.
+6 ;DGPTFMT=1 is very old record format, perhaps before ICD9 usage (not sure).
+7 ;DGPTFMT=2 is ICD9 record format
+8 ;DGPTFMT=3 is ICD10 record format
+9 ;DGPTR* & DGPTRI* routines and similiar, but record format is different.
+10 if DGPTFMT=1
DO ^DGPTFTR0
if DGPTFMT=2
DO ^DGPTR0
if DGPTFMT=3
DO ^DGPTRI0
+11 ;
Q ;
+1 LOCK -^DGP(45.83)
+2 FOR K=0,10,701,"401P",101,11,3,32,41,52,57,70,321,502,702,"02","06"
KILL @("DG"_K)
+3 ;** NOTE: do not kill variables needed by PTF load/edit option!!!
KILL DGPICD10,DGCDR,DGT,DIC,DGADM,DGAO,DGDOB,DGHEAD,DGJ,DGK,DGL,DGM,DGNAM,DGNT,DGO,DGSSN,DGSUD,DGSUR,DGTD,DGX,DGXLS,E,ERR,F,G,H,I,K,L,T,W,Z,DGPROC,DGPROCD
+4 ;DGPTFVC1 & DGPTFVC2 do expanded ptf close out edits
+5 ;DGPTFVC3 does validation checks for ptf additional questions
+6 IF $DATA(DGERR)
IF DGERR<1
DO ^DGPTFVC1
if 'T1
DO ^DGPTFVC3
+7 IF $DATA(DGERR)
IF DGERR<1
DO EN^DGPTFVC2
+8 QUIT
+9 ;
LOG ;called from PRINT+1^DGPTF2,CLS+1^DGPTF2,EN^DGPTFVC
+1 ;note: COM is not called unless DGERR exists
if DGPTFMT=1
DO LOG^DGPTFTR1
if DGPTFMT=2
DO LOG^DGPTR1
if DGPTFMT=3
DO LOG^DGPTRI1
if $DATA(DGERR)
DO COM
+2 QUIT
+3 ;
+4 ;-- check for real queue if census should be removed for national rel
ROUTER ;called from DGPTF099,DGPTRPO
+1 ;DGSDI is local or remote address
+2 ;I $D(XMDF) then all addressing restrictions are waived
+3 ;XMN - Can't find this variable in MailMan documentation. May not do anything.
+4 SET XMDUZ=.5
FOR DGSDI=0:0
SET DGSDI=$ORDER(VAT(DGSDI))
if 'DGSDI
QUIT
SET X=VAT(DGSDI)
SET XMN=0
SET XMDF=""
DO INST^XMA21
KILL XMN,XMDF
+5 SET XMY(DUZ)=""
+6 QUIT
+7 ;
CHECK(DGPTXMZ) ;check if every two lines in message body equal 384 characters
+1 NEW DGPTLAST,DGPTLOOP,DGPTNODE,DGPTTEXT,DGPTTOT
+2 SET DGPTNODE=$GET(^XMB(3.9,DGPTXMZ,2,0))
+3 SET DGPTLAST=$PIECE(DGPTNODE,U,4)
+4 FOR DGPTLOOP=1:2:DGPTLAST
Begin DoDot:1
+5 SET DGPTTOT=$LENGTH($GET(^XMB(3.9,DGPTXMZ,2,DGPTLOOP,0)))+$LENGTH($GET(^XMB(3.9,DGPTXMZ,2,DGPTLOOP+1,0)))
+6 IF DGPTTOT'=384
Begin DoDot:2
+7 ;segment length flag
SET DGPTSLF=1
+8 DO QMSG(DGPTXMZ)
+9 WRITE !!,"There is a problem with the segment length of a PTF record."
+10 WRITE !,"The MailMan message number is "_DGPTXMZ_"."
+11 WRITE !,"Please log a Remedy ticket. Stopping transmission.",!
End DoDot:2
End DoDot:1
if $GET(DGPTSLF)=1
QUIT
+12 QUIT
+13 ;
QMSG(DGPTMIEN) ;notify others about bad segment length
+1 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+2 SET ZTDESC="DG PTF TRANSMISSION VADATS"
SET ZTDTH=$$NOW^XLFDT()
SET ZTIO=""
SET ZTRTN="SMSG^DGPTFTR"
+3 SET ZTSAVE("DGPTMIEN")=""
+4 DO ^%ZTLOAD
+5 QUIT
+6 ;
SMSG ;send MailMan message
+1 NEW DGPTTEXT,XMDUZ,XMSUB,XMTEXT,XMY
+2 SET XMSUB="Station "_$PIECE($$SITE^VASITE(),U,3)_" has wrong PTF segment length"
+3 SET XMDUZ=$SELECT($GET(DUZ)>0:$GET(DUZ),1:.5)
+4 SET DGPTTEXT(1)="The PTF records contained in this message cannot be transmitted"
+5 SET DGPTTEXT(2)="to AITC due to format of the content issue."
+6 SET DGPTTEXT(3)=" "
+7 SET DGPTTEXT(4)="Contact the support help desk and report."
+8 SET DGPTTEXT(5)=" "
+9 SET DGPTTEXT(6)="Retransmission will need to be attempted once the transmission"
+10 SET DGPTTEXT(7)="message format has been corrected."
+11 SET DGPTTEXT(8)=" "
+12 SET DGPTTEXT(9)="The local MailMan message number is: "_DGPTMIEN
+13 SET XMTEXT="DGPTTEXT("
+14 SET XMY(DUZ)=""
+15 SET XMY("ICD-10OITPTFExpansionTeam@domain.ext")=""
+16 DO ^XMD
+17 QUIT
