IB20PT84 ;ALB/CPM - EXPORT ROUTINE 'DGPTTS1' ; 14-FEB-94
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
DGPTTS1 ;ALB/AS - FACILITY TREATING SPECIALTY AND 501 MOVEMENTS, cont. ; 11/28/89 @12
;;5.3;Registration;**26**;Aug 13, 1993
;
;build DGA array w/patient's last treat spec of the day as of 11:59 pm
;
LOOP ;
S DGNEXT=$O(^DGPM("ATS",DFN,DGPMCA,DGPREV))
F DGNEXT=DGNEXT:0 Q:($P(DGPREV,".")'=$P(DGNEXT,"."))!('DGNEXT) S DGNEXT=$O(^DGPM("ATS",DFN,DGPMCA,DGNEXT))
S X=$O(^DGPM("ATS",DFN,DGPMCA,DGPREV,0)),DGA(9999999.999999-$E(DGPREV,1,14))=$S($D(^DIC(45.7,+X,0)):$P(^(0),"^",2),1:0)_"^"_$O(^DGPM("ATS",DFN,DGPMCA,DGPREV,X,0)) I DGNEXT>0 S DGPREV=DGNEXT G LOOP
S DGPREV=0,X=$S($D(^DIC(42,+$P(DGPMAN,"^",6),0)):$P(^(0),"^",3),1:0) I "^NH^D^"[(U_X_U) D ASIH^DGPTTS2
;
LOOP1 ; -- compare specs between mvts ; sort out xfr if spec did't change
S DGSAVE=DGPREV
S DGPREV=$O(DGA(DGPREV)),DGNEXT=$O(DGA(DGPREV)),X=+DGA(DGPREV) I DGNEXT S Y=+DGA(DGNEXT) I (X=Y)!((X=70)&(Y=71))!((X=71)&(Y=70)) K DGA(DGNEXT) S DGPREV=DGSAVE I $O(DGA(DGPREV))>0 G LOOP1
;
; -- is mvt during adm
I DGPREV<+DGPMAN!($P(DGPREV,".")'<$S(DGDT:$P(+DGDT,"."),1:9999999)) S (DG1,DG2)=+$P(DGA(DGPREV),"^",2) D DEL:$S('$D(^DGPM(DG1,"PTF")):0,1:$P(^("PTF"),"^",2)]"") G LOOPQ
;
; build ^UTILITY for mvts whose spec changed
I X=70!(X=71) S X2=DGPREV,X1=$S(DGNEXT]"":DGNEXT,DGDT]"":DGDT,1:DT) D ^%DTC S $P(DGA(DGPREV),"^",1)=$S(X>45:71,1:70)
S X=$S($D(^DGPM($P(DGA(DGPREV),"^",2),"PTF")):^("PTF"),1:""),^UTILITY($J,"T",DGPREV)=$P(DGA(DGPREV),"^",2)_"^"_+DGA(DGPREV)_"^"_$P(X,"^",2)_"^"_$P(X,"^",3)_"^"_$S($D(^DGPM($P(DGA(DGPREV),"^",2),0)):$P(^(0),"^",8),1:"")
LOOPQ I $O(DGA(DGPREV)) G LOOP1
;
; look for mvts in ^DGPM that have a PTF mvt # entry
; but not in ^UTILITY. If any are found, delete from ^DGPT.
F DGPREV=0:0 S DGPREV=$O(^DGPM("ATS",DFN,DGPMCA,DGPREV)) Q:DGPREV'>0 S X=$O(^DGPM("ATS",DFN,DGPMCA,DGPREV,0)),(DG1,DG2)=$O(^DGPM("ATS",DFN,DGPMCA,DGPREV,+X,0)) I $D(^DGPM(+DG1,"PTF")),$P(^("PTF"),"^",2)]"" D DEL
;
K Y S Y=+$O(^DGPM("APHY",DGPMCA,0)) I $D(^DGPM(Y,0)) S Y(0)=^(0),Y("PTF")=$S($D(^("PTF")):^("PTF"),1:"")
I $D(Y)>10 S T("ADM")=Y_"^"_$S($D(^DIC(45.7,+$P(Y(0),"^",9),0)):$P(^(0),"^",2),1:"")_"^^"_$P(Y("PTF"),"^",3)_"^"_$P(Y(0),"^",8) K Y
;
S DGDEL=$O(^UTILITY($J,"T",0))
I DGDEL S T(DGDEL)=^(DGDEL),DG1=$P(T(DGDEL),"^",3) I DG1 S T(DGDEL)=$P(T(DGDEL),U,1,2),DGREC=$S($D(^DGPT(PTF,"M",DG1,0)):^(0),1:"") D MSG K DA S DIK="^DGPT("_PTF_",""M"",",DA(1)=PTF,DA=DG1 D ^DIK K DA S ^UTILITY($J,"T",DGDEL)=$P(T(DGDEL),U,1,2)
K DGA K:$D(T(+DGDT)) T(DGDT)
S DGAD=+DGPMAN F I=0:0 S I=$O(^UTILITY($J,"T",I)) Q:I'>0 S DGAD=I
S DGREC1=$S($D(^DGPT(PTF,"M",1,0)):^(0),1:""),DGREC=$S($D(^UTILITY($J,"T",DGAD)):^(DGAD),$D(T("ADM")):T("ADM"),1:"") I DGREC,$D(^DGPM(+DGREC,0)) S $P(^("PTF"),"^",3)=1
S DGREC=$P(DGREC,U,2)
I DGDT W:'DGREC&'$D(ZTQUEUED) !,"No Treating Specialty Transfers",! S I1=1,DIE="^DGPT(",DA=PTF,DR="71///"_DGREC D ^DIE:DGREC S PR=DGAD,NX=DGDT D LOL^DGPTTS2 I $P(DGREC1,U,3,4)'=(LOL_U_LOP) S DR="3///"_LOL_";4///"_LOP,I1=1 D TD5^DGPTTS2 K DR
I 'DGDT S PR=DGAD,NX=DT,I1=1 D LOL^DGPTTS2 I $P(DGREC1,U,2,4)'=(DGREC_U_LOL_U_LOP) S DR="3///"_LOL_";4///"_LOP_$S(DGREC:";2///"_DGREC,1:"") D TD5^DGPTTS2
K DGSAVE,DR,DGREC1 D ^DGPTTS2 Q
DEL Q:$D(^UTILITY($J,"T",(9999999.999999-$E(DGPREV,1,14))))
S DG1=$P(^DGPM(DG1,"PTF"),"^",2),DGREC=$S($D(^DGPT(PTF,"M",+DG1,0)):^(0),1:"") Q:DGREC']"" D MSG K DA S DIK="^DGPT("_PTF_",""M"",",DA(1)=PTF,DA=DG1 D ^DIK K DA
S DA=DG2,DR="52///@;53///@",DIE="^DGPM(" D ^DIE Q
MSG S DGMSG="" F X=5:1:15 S:X'=10 DGMSG=DGMSG_$S($D(^ICD9(+$P(DGREC,U,X),0)):$P(^(0),U,1)_", ",1:"")
Q:DGMSG']"" S ^UTILITY($J,"DEL",DG1)=DGMSG
;-- save expanded codes
S DGMSG1=""
I $D(^DGPT(PTF,"M",+DG1,300)) S DGEX=^(300) F X=2:1:7 S:$P(DGEX,U,X)]"" $P(DGMSG1,U,X)=$P(DGEX,U,X)
S:DGMSG1]"" ^UTILITY($J,300,DG1)=DGMSG1
K DGMSG1
S Y=$P(DGREC,U,10) X ^DD("DD") S DGMSG="501 movement of "_$P(^DPT(DFN,0),U,1)_" of "_Y_" losing specialty "_$P(^DIC(42.4,$P(DGREC,U,2),0),U,1)_" was deleted by "_$P(^VA(200,DUZ,0),U,1)_" it contained diag "_$E(DGMSG,1,120)
S:'$D(DGPMAN) DGPMAN=^DGPM(DGPMCA,0) D MSG^DGPTMSG1
K DGEX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT84 4202 printed Dec 13, 2024@02:05:30 Page 2
IB20PT84 ;ALB/CPM - EXPORT ROUTINE 'DGPTTS1' ; 14-FEB-94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
DGPTTS1 ;ALB/AS - FACILITY TREATING SPECIALTY AND 501 MOVEMENTS, cont. ; 11/28/89 @12
+1 ;;5.3;Registration;**26**;Aug 13, 1993
+2 ;
+3 ;build DGA array w/patient's last treat spec of the day as of 11:59 pm
+4 ;
LOOP ;
+1 SET DGNEXT=$ORDER(^DGPM("ATS",DFN,DGPMCA,DGPREV))
+2 FOR DGNEXT=DGNEXT:0
if ($PIECE(DGPREV,".")'=$PIECE(DGNEXT,"."))!('DGNEXT)
QUIT
SET DGNEXT=$ORDER(^DGPM("ATS",DFN,DGPMCA,DGNEXT))
+3 SET X=$ORDER(^DGPM("ATS",DFN,DGPMCA,DGPREV,0))
SET DGA(9999999.999999-$EXTRACT(DGPREV,1,14))=$SELECT($DATA(^DIC(45.7,+X,0)):$PIECE(^(0),"^",2),1:0)_"^"_$ORDER(^DGPM("ATS",DFN,DGPMCA,DGPREV,X,0))
IF DGNEXT>0
SET DGPREV=DGNEXT
GOTO LOOP
+4 SET DGPREV=0
SET X=$SELECT($DATA(^DIC(42,+$PIECE(DGPMAN,"^",6),0)):$PIECE(^(0),"^",3),1:0)
IF "^NH^D^"[(U_X_U)
DO ASIH^DGPTTS2
+5 ;
LOOP1 ; -- compare specs between mvts ; sort out xfr if spec did't change
+1 SET DGSAVE=DGPREV
+2 SET DGPREV=$ORDER(DGA(DGPREV))
SET DGNEXT=$ORDER(DGA(DGPREV))
SET X=+DGA(DGPREV)
IF DGNEXT
SET Y=+DGA(DGNEXT)
IF (X=Y)!((X=70)&(Y=71))!((X=71)&(Y=70))
KILL DGA(DGNEXT)
SET DGPREV=DGSAVE
IF $ORDER(DGA(DGPREV))>0
GOTO LOOP1
+3 ;
+4 ; -- is mvt during adm
+5 IF DGPREV<+DGPMAN!($PIECE(DGPREV,".")'<$SELECT(DGDT:$PIECE(+DGDT,"."),1:9999999))
SET (DG1,DG2)=+$PIECE(DGA(DGPREV),"^",2)
if $SELECT('$DATA(^DGPM(DG1,"PTF")):0,1:$PIECE(^("PTF"),"^",2)]"")
DO DEL
GOTO LOOPQ
+6 ;
+7 ; build ^UTILITY for mvts whose spec changed
+8 IF X=70!(X=71)
SET X2=DGPREV
SET X1=$SELECT(DGNEXT]"":DGNEXT,DGDT]"":DGDT,1:DT)
DO ^%DTC
SET $PIECE(DGA(DGPREV),"^",1)=$SELECT(X>45:71,1:70)
+9 SET X=$SELECT($DATA(^DGPM($PIECE(DGA(DGPREV),"^",2),"PTF")):^("PTF"),1:"")
SET ^UTILITY($JOB,"T",DGPREV)=$PIECE(DGA(DGPREV),"^",2)_"^"_+DGA(DGPREV)_"^"_$PIECE(X,"^",2)_"^"_$PIECE(X,"^",3)_"^"_$SELECT($DATA(^DGPM($PIECE(DGA(DGPREV),"^",2),0)):$PIECE(^(0),"^",8),1:"")
LOOPQ IF $ORDER(DGA(DGPREV))
GOTO LOOP1
+1 ;
+2 ; look for mvts in ^DGPM that have a PTF mvt # entry
+3 ; but not in ^UTILITY. If any are found, delete from ^DGPT.
+4 FOR DGPREV=0:0
SET DGPREV=$ORDER(^DGPM("ATS",DFN,DGPMCA,DGPREV))
if DGPREV'>0
QUIT
SET X=$ORDER(^DGPM("ATS",DFN,DGPMCA,DGPREV,0))
SET (DG1,DG2)=$ORDER(^DGPM("ATS",DFN,DGPMCA,DGPREV,+X,0))
IF $DATA(^DGPM(+DG1,"PTF"))
IF $PIECE(^("PTF"),"^",2)]""
DO DEL
+5 ;
+6 KILL Y
SET Y=+$ORDER(^DGPM("APHY",DGPMCA,0))
IF $DATA(^DGPM(Y,0))
SET Y(0)=^(0)
SET Y("PTF")=$SELECT($DATA(^("PTF")):^("PTF"),1:"")
+7 IF $DATA(Y)>10
SET T("ADM")=Y_"^"_$SELECT($DATA(^DIC(45.7,+$PIECE(Y(0),"^",9),0)):$PIECE(^(0),"^",2),1:"")_"^^"_$PIECE(Y("PTF"),"^",3)_"^"_$PIECE(Y(0),"^",8)
KILL Y
+8 ;
+9 SET DGDEL=$ORDER(^UTILITY($JOB,"T",0))
+10 IF DGDEL
SET T(DGDEL)=^(DGDEL)
SET DG1=$PIECE(T(DGDEL),"^",3)
IF DG1
SET T(DGDEL)=$PIECE(T(DGDEL),U,1,2)
SET DGREC=$SELECT($DATA(^DGPT(PTF,"M",DG1,0)):^(0),1:"")
DO MSG
KILL DA
SET DIK="^DGPT("_PTF_",""M"","
SET DA(1)=PTF
SET DA=DG1
DO ^DIK
KILL DA
SET ^UTILITY($JOB,"T",DGDEL)=$PIECE(T(DGDEL),U,1,2)
+11 KILL DGA
if $DATA(T(+DGDT))
KILL T(DGDT)
+12 SET DGAD=+DGPMAN
FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"T",I))
if I'>0
QUIT
SET DGAD=I
+13 SET DGREC1=$SELECT($DATA(^DGPT(PTF,"M",1,0)):^(0),1:"")
SET DGREC=$SELECT($DATA(^UTILITY($JOB,"T",DGAD)):^(DGAD),$DATA(T("ADM")):T("ADM"),1:"")
IF DGREC
IF $DATA(^DGPM(+DGREC,0))
SET $PIECE(^("PTF"),"^",3)=1
+14 SET DGREC=$PIECE(DGREC,U,2)
+15 IF DGDT
if 'DGREC&'$DATA(ZTQUEUED)
WRITE !,"No Treating Specialty Transfers",!
SET I1=1
SET DIE="^DGPT("
SET DA=PTF
SET DR="71///"_DGREC
if DGREC
DO ^DIE
SET PR=DGAD
SET NX=DGDT
DO LOL^DGPTTS2
IF $PIECE(DGREC1,U,3,4)'=(LOL_U_LOP)
SET DR="3///"_LOL_";4///"_LOP
SET I1=1
DO TD5^DGPTTS2
KILL DR
+16 IF 'DGDT
SET PR=DGAD
SET NX=DT
SET I1=1
DO LOL^DGPTTS2
IF $PIECE(DGREC1,U,2,4)'=(DGREC_U_LOL_U_LOP)
SET DR="3///"_LOL_";4///"_LOP_$SELECT(DGREC:";2///"_DGREC,1:"")
DO TD5^DGPTTS2
+17 KILL DGSAVE,DR,DGREC1
DO ^DGPTTS2
QUIT
DEL if $DATA(^UTILITY($JOB,"T",(9999999.999999-$EXTRACT(DGPREV,1,14))))
QUIT
+1 SET DG1=$PIECE(^DGPM(DG1,"PTF"),"^",2)
SET DGREC=$SELECT($DATA(^DGPT(PTF,"M",+DG1,0)):^(0),1:"")
if DGREC']""
QUIT
DO MSG
KILL DA
SET DIK="^DGPT("_PTF_",""M"","
SET DA(1)=PTF
SET DA=DG1
DO ^DIK
KILL DA
+2 SET DA=DG2
SET DR="52///@;53///@"
SET DIE="^DGPM("
DO ^DIE
QUIT
MSG SET DGMSG=""
FOR X=5:1:15
if X'=10
SET DGMSG=DGMSG_$SELECT($DATA(^ICD9(+$PIECE(DGREC,U,X),0)):$PIECE(^(0),U,1)_", ",1:"")
+1 if DGMSG']""
QUIT
SET ^UTILITY($JOB,"DEL",DG1)=DGMSG
+2 ;-- save expanded codes
+3 SET DGMSG1=""
+4 IF $DATA(^DGPT(PTF,"M",+DG1,300))
SET DGEX=^(300)
FOR X=2:1:7
if $PIECE(DGEX,U,X)]""
SET $PIECE(DGMSG1,U,X)=$PIECE(DGEX,U,X)
+5 if DGMSG1]""
SET ^UTILITY($JOB,300,DG1)=DGMSG1
+6 KILL DGMSG1
+7 SET Y=$PIECE(DGREC,U,10)
XECUTE ^DD("DD")
SET DGMSG="501 movement of "_$PIECE(^DPT(DFN,0),U,1)_" of "_Y_" losing specialty "_$PIECE(^DIC(42.4,$PIECE(DGREC,U,2),0),U,1)_" was deleted by "_$PIECE(^VA(200,DUZ,0),U,1)_" it contained diag "_$EXTRACT(DGMSG,1,120)
+8 if '$DATA(DGPMAN)
SET DGPMAN=^DGPM(DGPMCA,0)
DO MSG^DGPTMSG1
+9 KILL DGEX
QUIT
