DGPTAPA2 ;ALB/MTC - PTF A/P ARCHIVE UTILITY CONT. ; 10-19-92
;;5.3;Registration;;Aug 13, 1993
;
AR401 ;-- this function will load the 401 information
N X,X1,Y,I,J,K,OSEQ,SEQ
S OSEQ=$G(^DGP(45.62,DGTMP,100,0)) Q:OSEQ']""
S SEQ=$P(OSEQ,U,3),REF="^DGP(45.62,"_DGTMP_",100)"
;
S (K,I)=0 F S I=$O(^DGPT(DGPTF,"S",I)) Q:'I D
. S K=K+1,SEQ=SEQ+1,X=$G(^DGPT(DGPTF,"S",I,0)) Q:X']""
.;-- surgery date (4)
. S Y=DGPTF_U_"401"_U_K_U_$S($P(X,U):$P(X,U),1:"")
.;-- sur specialty (5)
. S Y=Y_U_$S($P(X,U,3):$P($G(^DIC(45.3,$P(X,U,3),0)),U,2),1:"")
.;-- cat of chief sur (6)
. S Y=Y_U_$S($P(X,U,4):$P($P($P(^DD(45.01,4,0),U,3),";",$P(X,U,4)),":",2),$P(X,U,4)="V":"VA TEAM",$P(X,U,4)="M":"MIXED VA&NON VA",$P(X,U,4)="N":"NON VA",1:"")
.;-- cat of first ass (7), pric ana (8), source of pay (9)
. F J=5,6,7 S Y=Y_U_$S($P(X,U,J):$P($P($P(^DD(45.01,J,0),U,3),";",$P(X,U,J)),":",2),1:"")
.;
.;-- check for ICD codes (10-14)
. F J=8:1:12 D
.. S Y=Y_U_$S($P(X,U,J):$P(^ICD0($P(X,U,J),0),U),1:"")
.;
.;-- check for 300 node information (15)
. S X2=$G(^DGPT(DGPTF,"S",I,300))
. S Y=Y_U_$S($P(X2,U,2)=1:"Live Donor",$P(X2,U,2)=2:"Cadaver",1:"")
. S SEQ=SEQ+1,@REF@(SEQ,0)=Y
.;
.;-- 401P
.;-- ICD codes (4-9)
. S X3=$G(^DGPT(DGPTF,"401P")) I X3]"" D S @REF@(SEQ,0)=Y
.. S SEQ=SEQ+1,Y=DGPTF_U_"401P"_U_K F J=1:1:5 I $P(X3,U,J) D
... S Y=Y_U_$P(^ICD0($P(X3,U,J),0),U)
.;
;
;-- update
S $P(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
Q
;
AR601 ;-- this function will load the 601 information
N X,Y,I,J,K,OSEQ,SEQ
S OSEQ=$G(^DGP(45.62,DGTMP,100,0)) Q:OSEQ']""
S SEQ=$P(OSEQ,U,3),REF="^DGP(45.62,"_DGTMP_",100)"
;
S (K,I)=0 F S I=$O(^DGPT(DGPTF,"P",I)) Q:'I D
. S K=K+1,SEQ=SEQ+1,X=$G(^DGPT(DGPTF,"P",I,0)) Q:X']""
.;-- procedure date (4)
. S Y=DGPTF_U_"601"_U_K_U_$S($P(X,U):$P(X,U),1:"")
.;-- specialty (5)
. S Y=Y_U_$P($G(^DIC(42.4,+$P(X,U,2),0)),U,1)
.;-- dialysis type (6)
. S Y=Y_U_$P($G(^DG(45.4,+$P(X,U,3),0)),U)
.;-- # of treat (7)
. S Y=Y_U_+$P(X,U,4)
.;-- ICD codes (8-12)
. F J=5:1:9 D
.. S Y=Y_U_$S($P(X,U,J):$P(^ICD0($P(X,U,J),0),U),1:"")
. S @REF@(SEQ,0)=Y
;
;-- update
S $P(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTAPA2 2230 printed Sep 23, 2025@20:27:31 Page 2
DGPTAPA2 ;ALB/MTC - PTF A/P ARCHIVE UTILITY CONT. ; 10-19-92
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
AR401 ;-- this function will load the 401 information
+1 NEW X,X1,Y,I,J,K,OSEQ,SEQ
+2 SET OSEQ=$GET(^DGP(45.62,DGTMP,100,0))
if OSEQ']""
QUIT
+3 SET SEQ=$PIECE(OSEQ,U,3)
SET REF="^DGP(45.62,"_DGTMP_",100)"
+4 ;
+5 SET (K,I)=0
FOR
SET I=$ORDER(^DGPT(DGPTF,"S",I))
if 'I
QUIT
Begin DoDot:1
+6 SET K=K+1
SET SEQ=SEQ+1
SET X=$GET(^DGPT(DGPTF,"S",I,0))
if X']""
QUIT
+7 ;-- surgery date (4)
+8 SET Y=DGPTF_U_"401"_U_K_U_$SELECT($PIECE(X,U):$PIECE(X,U),1:"")
+9 ;-- sur specialty (5)
+10 SET Y=Y_U_$SELECT($PIECE(X,U,3):$PIECE($GET(^DIC(45.3,$PIECE(X,U,3),0)),U,2),1:"")
+11 ;-- cat of chief sur (6)
+12 SET Y=Y_U_$SELECT($PIECE(X,U,4):$PIECE($PIECE($PIECE(^DD(45.01,4,0),U,3),";",$PIECE(X,U,4)),":",2),$PIECE(X,U,4)="V":"VA TEAM",$PIECE(X,U,4)="M":"MIXED VA&NON VA",$PIECE(X,U,4)="N":"NON VA",1:"")
+13 ;-- cat of first ass (7), pric ana (8), source of pay (9)
+14 FOR J=5,6,7
SET Y=Y_U_$SELECT($PIECE(X,U,J):$PIECE($PIECE($PIECE(^DD(45.01,J,0),U,3),";",$PIECE(X,U,J)),":",2),1:"")
+15 ;
+16 ;-- check for ICD codes (10-14)
+17 FOR J=8:1:12
Begin DoDot:2
+18 SET Y=Y_U_$SELECT($PIECE(X,U,J):$PIECE(^ICD0($PIECE(X,U,J),0),U),1:"")
End DoDot:2
+19 ;
+20 ;-- check for 300 node information (15)
+21 SET X2=$GET(^DGPT(DGPTF,"S",I,300))
+22 SET Y=Y_U_$SELECT($PIECE(X2,U,2)=1:"Live Donor",$PIECE(X2,U,2)=2:"Cadaver",1:"")
+23 SET SEQ=SEQ+1
SET @REF@(SEQ,0)=Y
+24 ;
+25 ;-- 401P
+26 ;-- ICD codes (4-9)
+27 SET X3=$GET(^DGPT(DGPTF,"401P"))
IF X3]""
Begin DoDot:2
+28 SET SEQ=SEQ+1
SET Y=DGPTF_U_"401P"_U_K
FOR J=1:1:5
IF $PIECE(X3,U,J)
Begin DoDot:3
+29 SET Y=Y_U_$PIECE(^ICD0($PIECE(X3,U,J),0),U)
End DoDot:3
End DoDot:2
SET @REF@(SEQ,0)=Y
+30 ;
End DoDot:1
+31 ;
+32 ;-- update
+33 SET $PIECE(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
+34 QUIT
+35 ;
AR601 ;-- this function will load the 601 information
+1 NEW X,Y,I,J,K,OSEQ,SEQ
+2 SET OSEQ=$GET(^DGP(45.62,DGTMP,100,0))
if OSEQ']""
QUIT
+3 SET SEQ=$PIECE(OSEQ,U,3)
SET REF="^DGP(45.62,"_DGTMP_",100)"
+4 ;
+5 SET (K,I)=0
FOR
SET I=$ORDER(^DGPT(DGPTF,"P",I))
if 'I
QUIT
Begin DoDot:1
+6 SET K=K+1
SET SEQ=SEQ+1
SET X=$GET(^DGPT(DGPTF,"P",I,0))
if X']""
QUIT
+7 ;-- procedure date (4)
+8 SET Y=DGPTF_U_"601"_U_K_U_$SELECT($PIECE(X,U):$PIECE(X,U),1:"")
+9 ;-- specialty (5)
+10 SET Y=Y_U_$PIECE($GET(^DIC(42.4,+$PIECE(X,U,2),0)),U,1)
+11 ;-- dialysis type (6)
+12 SET Y=Y_U_$PIECE($GET(^DG(45.4,+$PIECE(X,U,3),0)),U)
+13 ;-- # of treat (7)
+14 SET Y=Y_U_+$PIECE(X,U,4)
+15 ;-- ICD codes (8-12)
+16 FOR J=5:1:9
Begin DoDot:2
+17 SET Y=Y_U_$SELECT($PIECE(X,U,J):$PIECE(^ICD0($PIECE(X,U,J),0),U),1:"")
End DoDot:2
+18 SET @REF@(SEQ,0)=Y
End DoDot:1
+19 ;
+20 ;-- update
+21 SET $PIECE(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
+22 QUIT
+23 ;
