DGPTTS2 ;ALB/JDS - FACILITY TREATING SPECIALTY AND 501 MOVEMENTS, cont. ; 9/19/03 4:22pm
;;5.3;Registration;**549,478,1015**;Aug 13, 1993;Build 21
;
S NX=$O(^UTILITY($J,"T",0)),DGDR=0 Q:NX'>0 S T(NX)=^(NX),I2=$P(T(NX),U,4),B(501)=U
F I=0:0 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 D
.N FLD,DGFDA,DGMSG
.F FLD=20:1:25 S DGFDA(45.02,I_","_PTF_",",FLD)="@"
.D FILE^DIE("","DGFDA","DGMSG")
LOOP1 K:$D(PR) T(PR) S PR=NX,NX=$O(^UTILITY($J,"T",NX)) G Q:NX'>0 S T(NX)=^(NX),T(PR)=^(PR)
S I1=+$P(T(NX),U,3),I2=$S($O(^(NX)):$P(^(NX),U,3),1:0),DGDOC=$P(T(NX),U,5) F I=PR,NX S DG1(I)=$P(T(I),U,2)
D ADT1:I1'>0,ONE:$P(T(PR),U,4)'=I1,LOL
S A=$S($D(^DGPT(PTF,"M",I1,0)):^(0),1:"") I $P(A,U,1,4)'=(I1_U_DG1(PR)_U_LOL_U_LOP)!($P(A,U,10)'=NX) S DR=$S('A:".01///"_I1_";",1:"")_"2////"_DG1(PR)_";3///"_LOL_";4///"_LOP_";10////"_NX D TD5
I $P(T(PR),U,4)'=I1 S DR="53///"_I1,DA=+T(PR),DIE="^DGPM(" D ^DIE
G LOOP1
ADT1 S:'$D(^DGPT(PTF,"M",0)) ^DGPT(PTF,"M",0)="^45.02AI^1^1" L +^DGPT(PTF,"M",0) F I=0:0 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 S I1=I
S I1=I1+1,J=^DGPT(PTF,"M",0),^(0)=$P(J,U,1,2)_U_I1_U_($P(J,U,4)+1) L -^DGPT(PTF,"M",0)
N DGFDA,DGMSG
S DGFDA(45.02,I1_","_PTF_",",.01)=I1
D FILE^DIE("","DGFDA","DGMSG")
S T(NX)=$P(T(NX)_"^^",U,1,2)_U_I1
S DA=+T(NX),DR="52///"_I1,DIE="^DGPM(" D ^DIE
Q
ONE S I2=$P(T(PR),U,4) Q:'I2 S J=$S($D(^DGPT(PTF,"M",I2,0)):^(0),1:0) G O1:'J S (DR,DGDR)="" F I=4:1:9 S:$P(J,U,I) DR=DR_I_"///@;",DGDR=DGDR_I_"////"_$P(J,U,I)_";"
S J=$S($D(^DGPT(PTF,"M",I2,300)):^(300),1:""),(DR300,DGDR300)="" F I=2:1:7 S:$P(J,U,I)]"" DR300=DR300_"300.0"_I_"///@;",DGDR300=DGDR300_"300.0"_I_"////"_$P(J,U,I)_";"
S I1=I2 D TD5:DR]"" S DR=DR300 D TD5:DR]"" S I1=$P(T(NX),U,3),DR=DGDR D TD5:DR]"" S DR=DGDR300 D TD5:DR]""
K DGDR300,DR300 Q
TD5 S DA=I1,DIE="^DGPT("_PTF_",""M"",",DA(1)=PTF,DP=45.02 D ^DIE Q
LOL S DG1=$S(DGDT:DGDT,1:DT),(LOL,LOP)=0
F I=DGADM:0 S I=$O(^DGPM("APTT2",DFN,I)) Q:I'>0!(I>DG1) S J=$O(^DGPM("APTT2",DFN,I,0)) I $S('$D(^DGPM(J,0)):0,$P(^(0),"^",14)=DGPMCA:1,1:0) S C=+$P(^(0),"^",18) I C=1!(C=2)!(C=3) D LOL1
Q
LOL1 S X2=$S(I<PR:PR,1:I),Y=$O(^DGPM("APTT2",DFN,I)),X1=$S(Y>PR&(Y'>NX):+Y,Y>NX!(Y<0):NX,1:X2) I X1>X2 D ^%DTC S Z=$S(C=1:"LOP",1:"LOL"),@Z=@Z+X K C,X,Y,X1,X2
Q
;
ASIH S DGBDT=DGADM,DGEDT=$S(DGDT:DGDT,1:DT) D ASIH^DGUTL2
S DIE="^DGPT(",DA=PTF,DR="77////"_DGREC D ^DIE
K DE,DQ,DR,DA,DIE,DGBDT,DGEDT,DGMVTP Q
;
O1 Q:'$D(^UTILITY($J,"DEL",I2)) S DR="" F I=1:1 S J=$P(^(I2),", ",I) Q:J']"" S DR=DR_(I+4)_"///"_J_";"
S I1=$P(T(NX),U,3) D TD5:DR]""
;-- restore expanded codes
Q:'$D(^UTILITY($J,300,I2)) S DR="",DGEX=^(I2) F I=2:1:7 S:$P(DGEX,U,I)]"" DR=DR_"300.0"_I_"////"_$P(DGEX,U,I)_";"
D TD5:DR]""
Q
Q S T(PR)=^UTILITY($J,"T",PR) I $P(T(PR),U,4)>1 S NX=1,T(1)="^^1" D ONE
Q
CK ; -- checks for PTF# in ^DGPM and $D of the PTF in ^DGPT; Y = ifn of adm
Q:$D(^DGPT(+$P(^DGPM(Y,0),"^",16),0))
S Y=-1 W !,"warning: A PTF record does not exist for this admission - cannot edit",!?10,"Treating Specialty. MIS personnel and your supervisor should",!?10,"be notified."
W " The PTF option, 'Establish PTF record from Past",!?10,"Admission', may be used to create a PTF record." Q
;
DGPTTS2 ;ALB/JDS - FACILITY TREATING SPECIALTY AND 501 MOVEMENTS, cont. ; 9/19/03 4:22pm
+1 ;;5.3;Registration;**549,478,1015**;Aug 13, 1993;Build 21
+2 ;
+3 SET NX=$ORDER(^UTILITY($JOB,"T",0))
SET DGDR=0
IF NX'>0
QUIT
SET T(NX)=^(NX)
SET I2=$PIECE(T(NX),U,4)
SET B(501)=U
+4 FOR I=0:0
SET I=$ORDER(^DGPT(PTF,"M",I))
IF I'>0
QUIT
Begin DoDot:1
+5 NEW FLD,DGFDA,DGMSG
+6 FOR FLD=20:1:25
SET DGFDA(45.02,I_","_PTF_",",FLD)="@"
+7 DO FILE^DIE("","DGFDA","DGMSG")
End DoDot:1
LOOP1 IF $DATA(PR)
KILL T(PR)
SET PR=NX
SET NX=$ORDER(^UTILITY($JOB,"T",NX))
IF NX'>0
GOTO Q
SET T(NX)=^(NX)
SET T(PR)=^(PR)
+1 SET I1=+$PIECE(T(NX),U,3)
SET I2=$SELECT($ORDER(^(NX)):$PIECE(^(NX),U,3),1:0)
SET DGDOC=$PIECE(T(NX),U,5)
FOR I=PR,NX
SET DG1(I)=$PIECE(T(I),U,2)
+2 IF I1'>0
DO ADT1
IF $PIECE(T(PR),U,4)'=I1
DO ONE
DO LOL
+3 SET A=$SELECT($DATA(^DGPT(PTF,"M",I1,0)):^(0),1:"")
IF $PIECE(A,U,1,4)'=(I1_U_DG1(PR)_U_LOL_U_LOP)!($PIECE(A,U,10)'=NX)
SET DR=$SELECT('A:".01///"_I1_";",1:"")_"2////"_DG1(PR)_";3///"_LOL_";4///"_LOP_";10////"_NX
DO TD5
+4 IF $PIECE(T(PR),U,4)'=I1
SET DR="53///"_I1
SET DA=+T(PR)
SET DIE="^DGPM("
DO ^DIE
+5 GOTO LOOP1
ADT1 IF '$DATA(^DGPT(PTF,"M",0))
SET ^DGPT(PTF,"M",0)="^45.02AI^1^1"
LOCK +^DGPT(PTF,"M",0)
FOR I=0:0
SET I=$ORDER(^DGPT(PTF,"M",I))
IF I'>0
QUIT
SET I1=I
+1 SET I1=I1+1
SET J=^DGPT(PTF,"M",0)
SET ^(0)=$PIECE(J,U,1,2)_U_I1_U_($PIECE(J,U,4)+1)
LOCK -^DGPT(PTF,"M",0)
+2 NEW DGFDA,DGMSG
+3 SET DGFDA(45.02,I1_","_PTF_",",.01)=I1
+4 DO FILE^DIE("","DGFDA","DGMSG")
+5 SET T(NX)=$PIECE(T(NX)_"^^",U,1,2)_U_I1
+6 SET DA=+T(NX)
SET DR="52///"_I1
SET DIE="^DGPM("
DO ^DIE
+7 QUIT
ONE SET I2=$PIECE(T(PR),U,4)
IF 'I2
QUIT
SET J=$SELECT($DATA(^DGPT(PTF,"M",I2,0)):^(0),1:0)
IF 'J
GOTO O1
SET (DR,DGDR)=""
FOR I=4:1:9
IF $PIECE(J,U,I)
SET DR=DR_I_"///@;"
SET DGDR=DGDR_I_"////"_$PIECE(J,U,I)_";"
+1 SET J=$SELECT($DATA(^DGPT(PTF,"M",I2,300)):^(300),1:"")
SET (DR300,DGDR300)=""
FOR I=2:1:7
IF $PIECE(J,U,I)]""
SET DR300=DR300_"300.0"_I_"///@;"
SET DGDR300=DGDR300_"300.0"_I_"////"_$PIECE(J,U,I)_";"
+2 SET I1=I2
IF DR]""
DO TD5
SET DR=DR300
IF DR]""
DO TD5
SET I1=$PIECE(T(NX),U,3)
SET DR=DGDR
IF DR]""
DO TD5
SET DR=DGDR300
IF DR]""
DO TD5
+3 KILL DGDR300,DR300
QUIT
TD5 SET DA=I1
SET DIE="^DGPT("_PTF_",""M"","
SET DA(1)=PTF
SET DP=45.02
DO ^DIE
QUIT
LOL SET DG1=$SELECT(DGDT:DGDT,1:DT)
SET (LOL,LOP)=0
+1 FOR I=DGADM:0
SET I=$ORDER(^DGPM("APTT2",DFN,I))
IF I'>0!(I>DG1)
QUIT
SET J=$ORDER(^DGPM("APTT2",DFN,I,0))
IF $SELECT('$DATA(^DGPM(J,0)):0,$PIECE(^(0),"^",14)=DGPMCA:1,1:0)
SET C=+$PIECE(^(0),"^",18)
IF C=1!(C=2)!(C=3)
DO LOL1
+2 QUIT
LOL1 SET X2=$SELECT(I<PR:PR,1:I)
SET Y=$ORDER(^DGPM("APTT2",DFN,I))
SET X1=$SELECT(Y>PR&(Y'>NX):+Y,Y>NX!(Y<0):NX,1:X2)
IF X1>X2
DO ^%DTC
SET Z=$SELECT(C=1:"LOP",1:"LOL")
SET @Z=@Z+X
KILL C,X,Y,X1,X2
+1 QUIT
+2 ;
ASIH SET DGBDT=DGADM
SET DGEDT=$SELECT(DGDT:DGDT,1:DT)
DO ASIH^DGUTL2
+1 SET DIE="^DGPT("
SET DA=PTF
SET DR="77////"_DGREC
DO ^DIE
+2 KILL DE,DQ,DR,DA,DIE,DGBDT,DGEDT,DGMVTP
QUIT
+3 ;
O1 IF '$DATA(^UTILITY($JOB,"DEL",I2))
QUIT
SET DR=""
FOR I=1:1
SET J=$PIECE(^(I2),", ",I)
IF J']""
QUIT
SET DR=DR_(I+4)_"///"_J_";"
+1 SET I1=$PIECE(T(NX),U,3)
IF DR]""
DO TD5
+2 ;-- restore expanded codes
+3 IF '$DATA(^UTILITY($JOB,300,I2))
QUIT
SET DR=""
SET DGEX=^(I2)
FOR I=2:1:7
IF $PIECE(DGEX,U,I)]""
SET DR=DR_"300.0"_I_"////"_$PIECE(DGEX,U,I)_";"
+4 IF DR]""
DO TD5
+5 QUIT
Q SET T(PR)=^UTILITY($JOB,"T",PR)
IF $PIECE(T(PR),U,4)>1
SET NX=1
SET T(1)="^^1"
DO ONE
+1 QUIT
CK ; -- checks for PTF# in ^DGPM and $D of the PTF in ^DGPT; Y = ifn of adm
+1 IF $DATA(^DGPT(+$PIECE(^DGPM(Y,0),"^",16),0))
QUIT
+2 SET Y=-1
WRITE !,"warning: A PTF record does not exist for this admission - cannot edit",!?10,"Treating Specialty. MIS personnel and your supervisor should",!?10,"be notified."
+3 WRITE " The PTF option, 'Establish PTF record from Past",!?10,"Admission', may be used to create a PTF record."
QUIT
+4 ;
