DGPTFTR1 ;ALB/JDS - PTF VERIFICATION ; 01 DEC 87 @0800
;;5.3;Registration;**247**;Aug 13, 1993
START S T=$E(Y,2,3),T=$S(T=40&($E(Y,28)="P"):"P40",1:T),ERR=$P($T(@("T"_T)),";;",2),W=$P($T(@(T)),";;",2),H=28 F F=H:1:80 D L
D @("D"_T) Q
Q
L S X=$E(Y,F),DGO=$P(W,U,F+1-H),DGL=$P(DGLOGIC,U,+DGO) D @("ERR:"_DGL)
Q
T10 ;;NAME^SOURCE OF ADM^TRANS FAC.^SOURCE OF PAY^POW^MARITAL ST^SEX^DOB^COB^EXP^RESIDENCE^MEANS TEST
T70 ;;DATE OF DISP.^DISCH BD SEC^TYPE OF DIS^OUT TREAT^VA AUS^PLACE OF DIS^REC. FAC.^ASIH DAYS^RACE^C&P STATUS^DXLS^
T50 ;;DATE OF MOVEMENT^LOSING BD SEC^LEAVE DAYS^PASS DAYS^SCI^DIAGNOSES^DISCHARGE STATUS
T40 ;;DATE OF SURGERY^SURG SPEC.^CAT CHIEF SURGEON^CAT FIRST ASS^ANEST. TECH.^SOURCE OF PAY^OP CODE^
TP40 ;;OP CODE
T60 ;;DATE OF PROCEDURE^LOSING BD SEC^DIALYSIS TYPE^NUMBER OF TREATMENTS^PROCEDURE CODE
;;"NAME^INITIALS^SOURCE OF ADM.^TRANS FAC.^SOURCE PAY^DOB^COB^EXPOSURE^RESIDENCE^DATE OF DISCHARGE^DISCH BD SEC^TYPE OF DIS.^OUT TREAT^VA AUS^PLACE OF DIS^REC FAC^ASIH DAYS^RACE^C&P^DXLS^PRINC DIAG^DATE OF MOVEMENT"
;;^LOS BD SEC^LEAVE D^PASS D^SCI^DX^DATE OF SURGERY^SUR SPEC^CAT CHIEF SUR^CAT FIRST ASS^ANES TECH^OP CODES^
LOGIC ;;X'?.N^X'?.A^X'=" "^X'?.N&(X'=" ")^X'?.A&(X'=" ")^0^X'?.N&(X'="X")^X'=" "&(X'="P")^X="E"^X="Y"^X=" "^X'="A"&(X'=" ")^(X<1!(X>7))&'$P(DG0,U,4)
10 ;;6^6^6^6^6^6^6^6^6^6^6^6^2;1^5;1^1;2^2;2^4;3^4;3^4;3^6^6^6^4;4^6;5^2;6^2;7^1;8^1;8^1;8^1;8^1;8^1;8^1;8^1;8^11;9^4;10^4;10^1;11^1;11^1;11^1;11^1;11^7;11^7;11^7;11^7;11^7;11^2;12^6^3^3^3^3
70 ;;1;1^1;1^1;1^1;1^1;1^1;1^1;2^1;2^3;2^3;2^1;3^4;4^4;5^6^4;7^4;7^4;7^6^6^6^4;8^4;8^4;8^13;9^1;10^9;11^11;11^11;11^6^6^6^10;11^6^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^
50 ;;1;1^1;1^1;1^1;1^1;1^1;1^1;2^1;2^3;2^3;2^1;3^1;3^1;3^1;4^1;4^1;4^6^11;6^11;6^11;6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^3
40 ;;1;1^1;1^1;1^1;1^1;1^1;1^1;2^1;2^11;3^4;4^6;5^4;6^11;7^11;7^6^6^6^3;7^3;7^6^6^6^6^6^3;7^3;7^6^6^6^6^6^3;7^3;7^6^6^6^6^6^3;7^3;7^6^6^6^6^6^3;7^3;7^3^3^3^3^3^3^
P40 ;;8^3^3^3^3^3^3^3^3^3^3^3^11;1^11;1^6^6^6^3;1^3;1^6^6^6^6^6^3^3^6^6^6^6^6^3^3^6^6^6^6^6^3^3^6^6^6^6^6^3^3^3^3^3^3^3^3^
60 ;;1;1^1;1^1;1^1;1^1;1^1;1^1;2^1;2^4;3^4;4^4;4^4;4^11;5^11;5^11;5^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^3^3^3^3^3^3
Q
ERR S DGERR=1 W !,T,$S(T["H":" ",1:$E(Y,4))," " W:"45"[$E(T,1) $E(Y,28,29),"-",$E(Y,30,31),"-",$E(Y,32,33) W ?20,$P(ERR,U,$P(DGO,";",2)),?40,"COL.",F," VALUE: ",$S($E(Y,F)=" ":"BLANK",1:$E(Y,F))
S I=$S('$D(I):1,I>0:I,1:1),^(I)=$S($D(^UTILITY("DG",$J,T_$S(T["H":"",1:$E(Y,4)),I)):^(I),1:U) S:^(I)'[(U_$P(DGO,";",2)_U) ^(I)=^(I)_$P(DGO,";",2)_U
Q
D10 I $E(Y,62)="Z" S (F,H)=64,W="11;10" D L
I $P(^DGPT(J,0),"^",4),$P(^(0),"^",10)="U",$D(^DGPT(J,70)),+^(70)>2890700 S (F,H)=75,DGO="2;12" D ERR
Q
D40 Q
DP40 Q
D70 I "467"'[$E(Y,38) S H=39,W="4;4^1;5^11;6" F F=H:1:41 D L
Q
D50 I "A0"[$P(DG0,U,5)!('$D(^DGPT(J,70))) S W="11;5",(F,H)=44 D L
I $D(^DGPT(J,70)),$S(T1:1,1:+^(70)>2871000) S W="11;5",(F,H)=44 D L
I $E(Y,4)=1 S W="9;6",(F,H)=45 D L
I I=1,'T1 S W="1;7",(F,H)=80 D L
Q
D60 I $E(Y,36) S H=37,W="1;4^1;4^1;4" F F=H:1:39 D L
Q
HEAD S ERR="SSN^ADMISSION DATE^FACILITY #",W="8;1^1;1^1;1^1;1^1;1^1;1^1;1^1;1^1;1^1;1^3;1^1;2^1;2^1;2^1;2^1;2^1;2^1;3^1;3^1;3^6^6^6",H=5,DGLOGIC=$P($T(LOGIC),";;",2),T="HEADER"
F F=H:1:27 D L
Q
LOG S DGLOGIC=$P($T(LOGIC),";;",2)
Q
CEN S T=70,ERR=$P($T(T70),";;",2),W=$P($T(70),";;",2),W="4;8"_$P(W,"4;8",2,99),H=48 F F=H:1:80 D L
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFTR1 3469 printed Apr 09, 2024@21:50 Page 2
DGPTFTR1 ;ALB/JDS - PTF VERIFICATION ; 01 DEC 87 @0800
+1 ;;5.3;Registration;**247**;Aug 13, 1993
START SET T=$EXTRACT(Y,2,3)
SET T=$SELECT(T=40&($EXTRACT(Y,28)="P"):"P40",1:T)
SET ERR=$PIECE($TEXT(@("T"_T)),";;",2)
SET W=$PIECE($TEXT(@(T)),";;",2)
SET H=28
FOR F=H:1:80
DO L
+1 DO @("D"_T)
QUIT
+2 QUIT
L SET X=$EXTRACT(Y,F)
SET DGO=$PIECE(W,U,F+1-H)
SET DGL=$PIECE(DGLOGIC,U,+DGO)
DO @("ERR:"_DGL)
+1 QUIT
T10 ;;NAME^SOURCE OF ADM^TRANS FAC.^SOURCE OF PAY^POW^MARITAL ST^SEX^DOB^COB^EXP^RESIDENCE^MEANS TEST
T70 ;;DATE OF DISP.^DISCH BD SEC^TYPE OF DIS^OUT TREAT^VA AUS^PLACE OF DIS^REC. FAC.^ASIH DAYS^RACE^C&P STATUS^DXLS^
T50 ;;DATE OF MOVEMENT^LOSING BD SEC^LEAVE DAYS^PASS DAYS^SCI^DIAGNOSES^DISCHARGE STATUS
T40 ;;DATE OF SURGERY^SURG SPEC.^CAT CHIEF SURGEON^CAT FIRST ASS^ANEST. TECH.^SOURCE OF PAY^OP CODE^
TP40 ;;OP CODE
T60 ;;DATE OF PROCEDURE^LOSING BD SEC^DIALYSIS TYPE^NUMBER OF TREATMENTS^PROCEDURE CODE
+1 ;;"NAME^INITIALS^SOURCE OF ADM.^TRANS FAC.^SOURCE PAY^DOB^COB^EXPOSURE^RESIDENCE^DATE OF DISCHARGE^DISCH BD SEC^TYPE OF DIS.^OUT TREAT^VA AUS^PLACE OF DIS^REC FAC^ASIH DAYS^RACE^C&P^DXLS^PRINC DIAG^DATE OF MOVEMENT"
+2 ;;^LOS BD SEC^LEAVE D^PASS D^SCI^DX^DATE OF SURGERY^SUR SPEC^CAT CHIEF SUR^CAT FIRST ASS^ANES TECH^OP CODES^
LOGIC ;;X'?.N^X'?.A^X'=" "^X'?.N&(X'=" ")^X'?.A&(X'=" ")^0^X'?.N&(X'="X")^X'=" "&(X'="P")^X="E"^X="Y"^X=" "^X'="A"&(X'=" ")^(X<1!(X>7))&'$P(DG0,U,4)
10 ;;6^6^6^6^6^6^6^6^6^6^6^6^2;1^5;1^1;2^2;2^4;3^4;3^4;3^6^6^6^4;4^6;5^2;6^2;7^1;8^1;8^1;8^1;8^1;8^1;8^1;8^1;8^11;9^4;10^4;10^1;11^1;11^1;11^1;11^1;11^7;11^7;11^7;11^7;11^7;11^2;12^6^3^3^3^3
70 ;;1;1^1;1^1;1^1;1^1;1^1;1^1;2^1;2^3;2^3;2^1;3^4;4^4;5^6^4;7^4;7^4;7^6^6^6^4;8^4;8^4;8^13;9^1;10^9;11^11;11^11;11^6^6^6^10;11^6^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^3^
50 ;;1;1^1;1^1;1^1;1^1;1^1;1^1;2^1;2^3;2^3;2^1;3^1;3^1;3^1;4^1;4^1;4^6^11;6^11;6^11;6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^3
40 ;;1;1^1;1^1;1^1;1^1;1^1;1^1;2^1;2^11;3^4;4^6;5^4;6^11;7^11;7^6^6^6^3;7^3;7^6^6^6^6^6^3;7^3;7^6^6^6^6^6^3;7^3;7^6^6^6^6^6^3;7^3;7^6^6^6^6^6^3;7^3;7^3^3^3^3^3^3^
P40 ;;8^3^3^3^3^3^3^3^3^3^3^3^11;1^11;1^6^6^6^3;1^3;1^6^6^6^6^6^3^3^6^6^6^6^6^3^3^6^6^6^6^6^3^3^6^6^6^6^6^3^3^3^3^3^3^3^3^
60 ;;1;1^1;1^1;1^1;1^1;1^1;1^1;2^1;2^4;3^4;4^4;4^4;4^11;5^11;5^11;5^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^6^3^3^3^3^3^3
+1 QUIT
ERR SET DGERR=1
WRITE !,T,$SELECT(T["H":" ",1:$EXTRACT(Y,4))," "
if "45"[$EXTRACT(T,1)
WRITE $EXTRACT(Y,28,29),"-",$EXTRACT(Y,30,31),"-",$EXTRACT(Y,32,33)
WRITE ?20,$PIECE(ERR,U,$PIECE(DGO,";",2)),?40,"COL.",F," VALUE: ",$SELECT($EXTRACT(Y,F)=" ":"BLANK",1:$EXTRACT(Y,F))
+1 SET I=$SELECT('$DATA(I):1,I>0:I,1:1)
SET ^(I)=$SELECT($DATA(^UTILITY("DG",$JOB,T_$SELECT(T["H":"",1:$EXTRACT(Y,4)),I)):^(I),1:U)
if ^(I)'[(U_$PIECE(DGO,";",2)_U)
SET ^(I)=^(I)_$PIECE(DGO,";",2)_U
+2 QUIT
D10 IF $EXTRACT(Y,62)="Z"
SET (F,H)=64
SET W="11;10"
DO L
+1 IF $PIECE(^DGPT(J,0),"^",4)
IF $PIECE(^(0),"^",10)="U"
IF $DATA(^DGPT(J,70))
IF +^(70)>2890700
SET (F,H)=75
SET DGO="2;12"
DO ERR
+2 QUIT
D40 QUIT
DP40 QUIT
D70 IF "467"'[$EXTRACT(Y,38)
SET H=39
SET W="4;4^1;5^11;6"
FOR F=H:1:41
DO L
+1 QUIT
D50 IF "A0"[$PIECE(DG0,U,5)!('$DATA(^DGPT(J,70)))
SET W="11;5"
SET (F,H)=44
DO L
+1 IF $DATA(^DGPT(J,70))
IF $SELECT(T1:1,1:+^(70)>2871000)
SET W="11;5"
SET (F,H)=44
DO L
+2 IF $EXTRACT(Y,4)=1
SET W="9;6"
SET (F,H)=45
DO L
+3 IF I=1
IF 'T1
SET W="1;7"
SET (F,H)=80
DO L
+4 QUIT
D60 IF $EXTRACT(Y,36)
SET H=37
SET W="1;4^1;4^1;4"
FOR F=H:1:39
DO L
+1 QUIT
HEAD SET ERR="SSN^ADMISSION DATE^FACILITY #"
SET W="8;1^1;1^1;1^1;1^1;1^1;1^1;1^1;1^1;1^1;1^3;1^1;2^1;2^1;2^1;2^1;2^1;2^1;3^1;3^1;3^6^6^6"
SET H=5
SET DGLOGIC=$PIECE($TEXT(LOGIC),";;",2)
SET T="HEADER"
+1 FOR F=H:1:27
DO L
+2 QUIT
LOG SET DGLOGIC=$PIECE($TEXT(LOGIC),";;",2)
+1 QUIT
CEN SET T=70
SET ERR=$PIECE($TEXT(T70),";;",2)
SET W=$PIECE($TEXT(70),";;",2)
SET W="4;8"_$PIECE(W,"4;8",2,99)
SET H=48
FOR F=H:1:80
DO L
