DGPTR3 ;ALB/JDS/MJK/BOK,HIOFO/FT - PTF TRANSMISSION ;4/17/15 3:10pm
;;5.3;Registration;**183,729,884**;Aug 13, 1993;Build 31
;
; no external references
;
535 ; -- setup 535 transactions
F I=0:0 S I=$O(^DGPT(J,535,I)) Q:'I I $D(^(I,0)) S DGM=^(0),DGTD=+$P(DGM,U,10) I $P(DGM,U,17)'="n",'$P(DGM,U,7),'$D(^DGPT(J,"M","AM",DGTD)),DGTD'<T1,DGTD'>T2 D PHY
Q
;
PHY ; -- set up physical mvt
S Y=$S(T1:"C",1:"N")_"535"_DGHEAD,X=$P(DGTD,".")_" ",Y=Y_$E(X,4,5)_$E(X,6,7)_$E(X,2,3)_$E($P(DGTD,".",2)_"0000",1,4)
; physical cdr
S Z=$P(DGM,U,16) D CDR^DGPTR2
; physical specialty
;replace specialty pointer (ien) with ptf code (alpha-numeric)
N DGARRX,DGARRY ;DG729
S DGARRX=$$TSDATA^DGACT(42.4,$P(DGM,U,2),.DGARRY)
S $P(DGM,U,2)=$G(DGARRY(7))
S L=2,X=DGM,Z=2 D ENTER0
; find corresponding PTF mvt
S X="",Z=+$O(^DGPT(J,"M","AM",DGTD-.0000001)),Z=$S(Z:+$O(^(Z,0)),1:1) I $D(^DGPT(J,"M",Z,0)) S X=^(0) ; use d/c mvt if 'Z
; specialty cdr
S Z=$P(X,U,16) D CDR^DGPTR2
; specialty
;replace specialty pointer (ien) with ptf code (alpha-numeric)
N DGARRX,DGARRY ;DG729
S DGARRX=$$TSDATA^DGACT(42.4,$P(X,U,2),.DGARRY)
S $P(X,U,2)=$G(DGARRY(7))
S L=2,Z=2 D ENTER0
;
; convert pass, leave days >999 to 999
S X=DGM,L=3 F Z=3,4 S:$P(X,U,Z)>999 $P(X,U,Z)=999 D ENTER0
D FILL^DGPTR2,SAVE
K DGM,X,Z,L Q
;
ENTER S Y=Y_$J($P(X,U,Z),L)
Q
;
ENTER0 S Y=Y_$S($P(X,U,Z)]"":$E("00000",$L($P(X,U,Z))+1,L)_$P(X,U,Z),1:$J($P(X,U,Z),L))
Q
;
SAVE ;
D SAVE^DGPTR2
Q Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTR3 1514 printed Sep 23, 2025@20:29:17 Page 2
DGPTR3 ;ALB/JDS/MJK/BOK,HIOFO/FT - PTF TRANSMISSION ;4/17/15 3:10pm
+1 ;;5.3;Registration;**183,729,884**;Aug 13, 1993;Build 31
+2 ;
+3 ; no external references
+4 ;
535 ; -- setup 535 transactions
+1 FOR I=0:0
SET I=$ORDER(^DGPT(J,535,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET DGM=^(0)
SET DGTD=+$PIECE(DGM,U,10)
IF $PIECE(DGM,U,17)'="n"
IF '$PIECE(DGM,U,7)
IF '$DATA(^DGPT(J,"M","AM",DGTD))
IF DGTD'<T1
IF DGTD'>T2
DO PHY
+2 QUIT
+3 ;
PHY ; -- set up physical mvt
+1 SET Y=$SELECT(T1:"C",1:"N")_"535"_DGHEAD
SET X=$PIECE(DGTD,".")_" "
SET Y=Y_$EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)_$EXTRACT($PIECE(DGTD,".",2)_"0000",1,4)
+2 ; physical cdr
+3 SET Z=$PIECE(DGM,U,16)
DO CDR^DGPTR2
+4 ; physical specialty
+5 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+6 ;DG729
NEW DGARRX,DGARRY
+7 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(DGM,U,2),.DGARRY)
+8 SET $PIECE(DGM,U,2)=$GET(DGARRY(7))
+9 SET L=2
SET X=DGM
SET Z=2
DO ENTER0
+10 ; find corresponding PTF mvt
+11 ; use d/c mvt if 'Z
SET X=""
SET Z=+$ORDER(^DGPT(J,"M","AM",DGTD-.0000001))
SET Z=$SELECT(Z:+$ORDER(^(Z,0)),1:1)
IF $DATA(^DGPT(J,"M",Z,0))
SET X=^(0)
+12 ; specialty cdr
+13 SET Z=$PIECE(X,U,16)
DO CDR^DGPTR2
+14 ; specialty
+15 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+16 ;DG729
NEW DGARRX,DGARRY
+17 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
+18 SET $PIECE(X,U,2)=$GET(DGARRY(7))
+19 SET L=2
SET Z=2
DO ENTER0
+20 ;
+21 ; convert pass, leave days >999 to 999
+22 SET X=DGM
SET L=3
FOR Z=3,4
if $PIECE(X,U,Z)>999
SET $PIECE(X,U,Z)=999
DO ENTER0
+23 DO FILL^DGPTR2
DO SAVE
+24 KILL DGM,X,Z,L
QUIT
+25 ;
ENTER SET Y=Y_$JUSTIFY($PIECE(X,U,Z),L)
+1 QUIT
+2 ;
ENTER0 SET Y=Y_$SELECT($PIECE(X,U,Z)]"":$EXTRACT("00000",$LENGTH($PIECE(X,U,Z))+1,L)_$PIECE(X,U,Z),1:$JUSTIFY($PIECE(X,U,Z),L))
+1 QUIT
+2 ;
SAVE ;
+1 DO SAVE^DGPTR2
Q QUIT
