DGPTFTR2 ;ALB/JDS/TJ - ALB/BOK PTF TRANSMISSION ;01 DEC 87 @0800
;;5.3;Registration;**729,850**;Aug 13, 1993;Build 171
501 ;
K DGCMVT I T2'=9999999 S DGCMVT=$O(^DGPT(J,"M","AM",+$P(T2,".")_".2359")),DGCMVT=$S('DGCMVT:1,$O(^(DGCMVT,0)):$O(^(0)),1:1)
N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
F I=0:0 S I=$O(^DGPT(J,"M",I)) G PROC:I'>0 I $D(^(I,0)) S DGM=^(0),DGTD=$P(DGM,U,10) S:$D(DGCMVT) DGTD=$S(I=DGCMVT:$P(T2,".")_".2359",1:DGTD) I $P(DGM,U,17)'="n",DGTD,DGTD'<T1,DGTD'>T2 D MOV
MOV S DGM=$P(DGM,U,1,9)_U_$P(DGM,U,11,15),L=1
F Z=5:1:14 S:'$P(DGM,U,Z) DGM=$P(DGM,U,1,Z-1)_U_$P(DGM,U,Z+1,99) S:'$P(DGM,U,Z) Z=Z-1 S L=L+1 Q:L=10
S Y=$S(T1:"C",1:"N")_"501"_DGHEAD,X=$P(DGTD,".")_" ",Y=Y_$E(X,4,5)_$E(X,6,7)_$E(X,2,3)
N DGSARRX,DGSARRY
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 S Y=Y_" "
S L=3 F Z=3,4 D ENTER0
S L=1,X=DG57,Z=4 D ENTER S:I=1 DG502=Y
F Z=5:1:9 S F=$$ICDDATA^ICDXCODE("DIAG",+$P(DGM,U,Z),EFFDATE,"I") S F=$S(+F'<0:$P(F,U,2),1:" ."),F=$P(F,".",1)_$E($P(F,".",2)_" ",1,3),F=F_$E(" ",1,7-$L(F)),Y=Y_F
; bed occupant
I T1 S Y=Y_$S(I=1:$E($P(DG70,U,14)_" "),$P(+DGTD,".")=$P(T2,"."):5,1:1)
I 'T1 S Y=Y_$S(I=1:$E($P(DG70,U,14)_" "),1:" ")
D SAVE
Q
;
PROC K DGCMVT,^UTILITY($J,"PROC") S I=0
601 ;
N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
S I=$O(^DGPT(J,"P",I)) G 701:I'>0 S (X,DGPROC)=^(I,0) G 601:'DGPROC
G 601:DGPROC<T1!(DGPROC>T2) S DGPROCD=+^DGPT(J,"P",I,0)\1,^UTILITY($J,"PROC",DGPROCD)=$S($D(^UTILITY($J,"PROC",DGPROCD)):^(DGPROCD),1:0)+1
I ^UTILITY($J,"PROC",DGPROCD)>1 W !,"More than one procedure record on same date" S DGERR=1 Q
S Y=$S('T1:"N",1:"C")_"60"_^(DGPROCD)_DGHEAD_$E(DGPROCD,4,7)_$E(DGPROCD,2,3)
N DGARRY,DGARRX ;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 S L=1,Z=3 D ENTER S L=3,Z=4 D ENTER0
S L=1 F K=5:1:9 S:'$P(DGPROC,U,K) DGPROC=$P(DGPROC,U,1,K-1)_U_$P(DGPROC,U,K+1,99),K=K-1 S L=L+1 Q:L=5
F K=5:1:9 S F=$$ICDDATA^ICDXCODE("PROC",+$P(DGPROC,U,K),EFFDATE,"I") S Y=Y_$S(F'<0:$J($P($P(F,U,2),".",1),2)_$E($P($P(F,U,2),".",2)_" ",1,3),1:" ")_" "
S Y=Y_" " K DGPTEDT D SAVE G 601
Q
;
701 S Y=$S(T1:"C",1:"N")_"701"_DGHEAD,DGDDX=+DG70\1_" ",Y=Y_$E(DGDDX,4,5)_$E(DGDDX,6,7)_$E(DGDDX,2,3)
S X=DG70
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,Z)=2 D ENTER0 S Y=Y_" " K DGDDX
S X=DG70 I "467"[($P(X,U,3)\1) S Y=Y_$P(X,U,3)_" " G J
S L=1 F Z=3:1:5 D ENTER
S Y=Y_$S($D(^DIC(45.6,+$P(X,U,6),0)):$P(^(0),U,2),1:" "),L=3,Z=12 D ENTER S Y=Y_$E($P(X,U,13)_" ",1,3)
J S L=3,Z=8 D ENTER0
S Y=Y_$S($D(^DIC(10,+$P(DG10,U,6),0)):$J($P(^(0),U,2),1),1:" ")_$J($P(DG70,U,9),1)
S DGXLS=$$ICDDATA^ICDXCODE("DIAG",+$P(DG70,U,10),EFFDATE,"I") S DGXLS=$S(DGXLS'<0:$P(DGXLS,U,2),1:""),Y=Y_$S(DGXLS[".":$J($P(DGXLS,".",1),3)_$E($P(DGXLS,".",2)_" ",1,3),1:$J(DGXLS,6))_" "
S L=$P(DG70,U,16,24) S DG702=""
F K=1:1:9 S DGXLS=$$ICDDATA^ICDXCODE("DIAG",+$P(L,U,K),EFFDATE,"I") I +DGXLS'<0 S DG702=DG702_$P(DGXLS,U,2)_U
I DG702']"" S Y=Y_"X" K DGPTEDT
D Y
I T1 F K=34:1:47,60 S Y=$E(Y,1,K-1)_" "_$E(Y,K+1,80)
I T1 D CEN^DGPTFTR1 S:'DGERR ^UTILITY($J,DGCNT,0)=Y,DGCNT=DGCNT+1 Q
I 'T1 D SAVE
702 ;
Q:DG702']""
S Y="N702"_$E(Y,5,33)
F K=1:1:5 S F=$P(DG702,U,K),F=$P(F,".",1)_$E($P(F,".",2)_" ",1,3),F=F_$E(" ",1,7-$L(F)),Y=Y_F
D Y
I 'DGERR S ^UTILITY($J,DGCNT,0)=Y,DGCNT=DGCNT+1
S DG702=$P(DG702,U,6,9)
;
703 Q:DG702']""
S Y="N703"_$E(Y,5,33)
F K=1:1:4 S F=$P(DG702,U,K),F=$P(F,".",1)_$E($P(F,".",2)_" ",1,3),F=F_$E(" ",1,7-$L(F)),Y=Y_F
D Y
I 'DGERR S ^UTILITY($J,DGCNT,0)=Y,DGCNT=DGCNT+1
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 START^DGPTFTR1 S:'DGERR ^UTILITY($J,DGCNT,0)=Y,DGCNT=DGCNT+1
Q Q
;
Y F K=$L(Y):1:79 S Y=Y_" "
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFTR2 4013 printed Sep 23, 2025@20:28:30 Page 2
DGPTFTR2 ;ALB/JDS/TJ - ALB/BOK PTF TRANSMISSION ;01 DEC 87 @0800
+1 ;;5.3;Registration;**729,850**;Aug 13, 1993;Build 171
501 ;
+1 KILL DGCMVT
IF T2'=9999999
SET DGCMVT=$ORDER(^DGPT(J,"M","AM",+$PIECE(T2,".")_".2359"))
SET DGCMVT=$SELECT('DGCMVT:1,$ORDER(^(DGCMVT,0)):$ORDER(^(0)),1:1)
+2 NEW EFFDATE,IMPDATE,DGPTDAT
DO EFFDATE^DGPTIC10(J)
+3 FOR I=0:0
SET I=$ORDER(^DGPT(J,"M",I))
if I'>0
GOTO PROC
IF $DATA(^(I,0))
SET DGM=^(0)
SET DGTD=$PIECE(DGM,U,10)
if $DATA(DGCMVT)
SET DGTD=$SELECT(I=DGCMVT:$PIECE(T2,".")_".2359",1:DGTD)
IF $PIECE(DGM,U,17)'="n"
IF DGTD
IF DGTD'<T1
IF DGTD'>T2
DO MOV
MOV SET DGM=$PIECE(DGM,U,1,9)_U_$PIECE(DGM,U,11,15)
SET L=1
+1 FOR Z=5:1:14
if '$PIECE(DGM,U,Z)
SET DGM=$PIECE(DGM,U,1,Z-1)_U_$PIECE(DGM,U,Z+1,99)
if '$PIECE(DGM,U,Z)
SET Z=Z-1
SET L=L+1
if L=10
QUIT
+2 SET Y=$SELECT(T1:"C",1:"N")_"501"_DGHEAD
SET X=$PIECE(DGTD,".")_" "
SET Y=Y_$EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)
+3 NEW DGSARRX,DGSARRY
+4 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(DGM,U,2),.DGARRY)
+5 SET $PIECE(DGM,U,2)=$GET(DGARRY(7))
+6 SET L=2
SET X=DGM
SET Z=2
DO ENTER0
SET Y=Y_" "
+7 SET L=3
FOR Z=3,4
DO ENTER0
+8 SET L=1
SET X=DG57
SET Z=4
DO ENTER
if I=1
SET DG502=Y
+9 FOR Z=5:1:9
SET F=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DGM,U,Z),EFFDATE,"I")
SET F=$SELECT(+F'<0:$PIECE(F,U,2),1:" .")
SET F=$PIECE(F,".",1)_$EXTRACT($PIECE(F,".",2)_" ",1,3)
SET F=F_$EXTRACT(" ",1,7-$LENGTH(F))
SET Y=Y_F
+10 ; bed occupant
+11 IF T1
SET Y=Y_$SELECT(I=1:$EXTRACT($PIECE(DG70,U,14)_" "),$PIECE(+DGTD,".")=$PIECE(T2,"."):5,1:1)
+12 IF 'T1
SET Y=Y_$SELECT(I=1:$EXTRACT($PIECE(DG70,U,14)_" "),1:" ")
+13 DO SAVE
+14 QUIT
+15 ;
PROC KILL DGCMVT,^UTILITY($JOB,"PROC")
SET I=0
601 ;
+1 NEW EFFDATE,IMPDATE,DGPTDAT
DO EFFDATE^DGPTIC10(J)
+2 SET I=$ORDER(^DGPT(J,"P",I))
if I'>0
GOTO 701
SET (X,DGPROC)=^(I,0)
if 'DGPROC
GOTO 601
+3 if DGPROC<T1!(DGPROC>T2)
GOTO 601
SET DGPROCD=+^DGPT(J,"P",I,0)\1
SET ^UTILITY($JOB,"PROC",DGPROCD)=$SELECT($DATA(^UTILITY($JOB,"PROC",DGPROCD)):^(DGPROCD),1:0)+1
+4 IF ^UTILITY($JOB,"PROC",DGPROCD)>1
WRITE !,"More than one procedure record on same date"
SET DGERR=1
QUIT
+5 SET Y=$SELECT('T1:"N",1:"C")_"60"_^(DGPROCD)_DGHEAD_$EXTRACT(DGPROCD,4,7)_$EXTRACT(DGPROCD,2,3)
+6 ;DG729
NEW DGARRY,DGARRX
+7 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
+8 SET $PIECE(X,U,2)=$GET(DGARRY(7))
+9 SET L=2
SET Z=2
DO ENTER0
SET L=1
SET Z=3
DO ENTER
SET L=3
SET Z=4
DO ENTER0
+10 SET L=1
FOR K=5:1:9
if '$PIECE(DGPROC,U,K)
SET DGPROC=$PIECE(DGPROC,U,1,K-1)_U_$PIECE(DGPROC,U,K+1,99)
SET K=K-1
SET L=L+1
if L=5
QUIT
+11 FOR K=5:1:9
SET F=$$ICDDATA^ICDXCODE("PROC",+$PIECE(DGPROC,U,K),EFFDATE,"I")
SET Y=Y_$SELECT(F'<0:$JUSTIFY($PIECE($PIECE(F,U,2),".",1),2)_$EXTRACT($PIECE($PIECE(F,U,2),".",2)_" ",1,3),1:" ")_" "
+12 SET Y=Y_" "
KILL DGPTEDT
DO SAVE
GOTO 601
+13 QUIT
+14 ;
701 SET Y=$SELECT(T1:"C",1:"N")_"701"_DGHEAD
SET DGDDX=+DG70\1_" "
SET Y=Y_$EXTRACT(DGDDX,4,5)_$EXTRACT(DGDDX,6,7)_$EXTRACT(DGDDX,2,3)
+1 SET X=DG70
+2 ;DG729
NEW DGARRX,DGARRY
+3 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
+4 SET $PIECE(X,U,2)=$GET(DGARRY(7))
+5 SET (L,Z)=2
DO ENTER0
SET Y=Y_" "
KILL DGDDX
+6 SET X=DG70
IF "467"[($PIECE(X,U,3)\1)
SET Y=Y_$PIECE(X,U,3)_" "
GOTO J
+7 SET L=1
FOR Z=3:1:5
DO ENTER
+8 SET Y=Y_$SELECT($DATA(^DIC(45.6,+$PIECE(X,U,6),0)):$PIECE(^(0),U,2),1:" ")
SET L=3
SET Z=12
DO ENTER
SET Y=Y_$EXTRACT($PIECE(X,U,13)_" ",1,3)
J SET L=3
SET Z=8
DO ENTER0
+1 SET Y=Y_$SELECT($DATA(^DIC(10,+$PIECE(DG10,U,6),0)):$JUSTIFY($PIECE(^(0),U,2),1),1:" ")_$JUSTIFY($PIECE(DG70,U,9),1)
+2 SET DGXLS=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DG70,U,10),EFFDATE,"I")
SET DGXLS=$SELECT(DGXLS'<0:$PIECE(DGXLS,U,2),1:"")
SET Y=Y_$SELECT(DGXLS[".":$JUSTIFY($PIECE(DGXLS,".",1),3)_$EXTRACT($PIECE(DGXLS,".",2)_" ",1,3),1:$JUSTIFY(DGXLS,6))_" "
+3 SET L=$PIECE(DG70,U,16,24)
SET DG702=""
+4 FOR K=1:1:9
SET DGXLS=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(L,U,K),EFFDATE,"I")
IF +DGXLS'<0
SET DG702=DG702_$PIECE(DGXLS,U,2)_U
+5 IF DG702']""
SET Y=Y_"X"
KILL DGPTEDT
+6 DO Y
+7 IF T1
FOR K=34:1:47,60
SET Y=$EXTRACT(Y,1,K-1)_" "_$EXTRACT(Y,K+1,80)
+8 IF T1
DO CEN^DGPTFTR1
if 'DGERR
SET ^UTILITY($JOB,DGCNT,0)=Y
SET DGCNT=DGCNT+1
QUIT
+9 IF 'T1
DO SAVE
702 ;
+1 if DG702']""
QUIT
+2 SET Y="N702"_$EXTRACT(Y,5,33)
+3 FOR K=1:1:5
SET F=$PIECE(DG702,U,K)
SET F=$PIECE(F,".",1)_$EXTRACT($PIECE(F,".",2)_" ",1,3)
SET F=F_$EXTRACT(" ",1,7-$LENGTH(F))
SET Y=Y_F
+4 DO Y
+5 IF 'DGERR
SET ^UTILITY($JOB,DGCNT,0)=Y
SET DGCNT=DGCNT+1
+6 SET DG702=$PIECE(DG702,U,6,9)
+7 ;
703 if DG702']""
QUIT
+1 SET Y="N703"_$EXTRACT(Y,5,33)
+2 FOR K=1:1:4
SET F=$PIECE(DG702,U,K)
SET F=$PIECE(F,".",1)_$EXTRACT($PIECE(F,".",2)_" ",1,3)
SET F=F_$EXTRACT(" ",1,7-$LENGTH(F))
SET Y=Y_F
+3 DO Y
+4 IF 'DGERR
SET ^UTILITY($JOB,DGCNT,0)=Y
SET DGCNT=DGCNT+1
+5 QUIT
+6 ;
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 DO START^DGPTFTR1
if 'DGERR
SET ^UTILITY($JOB,DGCNT,0)=Y
SET DGCNT=DGCNT+1
Q QUIT
+1 ;
Y FOR K=$LENGTH(Y):1:79
SET Y=Y_" "
+1 QUIT
