DGPTTS ;ALB/AS/ADL - UPDATE FACILITY TREATING SPECIALTY/501 MOVEMENTS IN PTF ; 1/30/90 @12
;;5.3;Registration;**26,61,164,510,1015**;Aug 13, 1993;Build 21
;;ADL;Update for CSV Project;;Mar 28, 2003
;needs to be done - OERR link
;
EV ;entry point from event driver
D EV^DGPTTS0
Q
;
DEL ;facility treating specialty has been deleted from ^DGPM
S DGPTFP=^UTILITY("DGPM",$J,6,DGMV,"PTFP")
G DEL1:'$D(^DGPT(PTF,"M",+$P(DGPTFP,"^",2),0))
K DA S DGREC=^(0),DGEX=$S($D(^(300)):^(300),1:""),DA=$P(DGPTFP,"^",2),DA(1)=PTF,DIK="^DGPT("_DA(1)_",""M""," D ^DIK K DA
S DGMSG="" F X=5:1:15 I X'=10 S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGREC,U,X),$$GETDATE^ICDGTDRG(PTF)),DGMSG=DGMSG_$S(+DGPTTMP>0:$P(DGPTTMP,U,2)_", ",1:"")
G DEL1:DGMSG']"" S ^UTILITY($J,"DEL",$P(DGPTFP,"^",2))=DGMSG
;-- save expanded codes
S DG1=""
I DGEX]"" F X=2:1:7 S:$P(DGEX,U,X)]"" $P(DG1,U,X)=$P(DGEX,U,X)
S:DG1]"" ^UTILITY($J,300,$P(DGPTFP,U,2))=DG1
K DGI
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 DGMSG1="501 Movement Deletion" D MSG^DGPTMSG1
;
DEL1 S X=^DPT(DFN,0),DGMSG="A transfer between treating specialties for "_$P(X,U,1)_" ("_$P(X,U,9)_") on "_$TR($$FMTE^XLFDT(+DGMVP,"5DF")," ","0")_" was deleted by "_$P(^VA(200,+DUZ,0),U)_". Please verify PTF #"_PTF_"."
S DGMSG1="Facility Treating Specialty Deletion" D MSG^DGPTMSG1
;
S DR="" I $P(DGPTFP,"^",3)=1 S DGREC=^DGPT(PTF,"M",1,0) F X=5:1:15 I X'=10 S:$P(DGREC,U,X) DR=DR_X_"///@;"
I DR]"" S DA(1)=PTF,DIE="^DGPT("_DA(1)_",""M"",",DA=1 D ^DIE
;-- clean up expanded code data
S DR="" I $P(DGPTFP,U,3)=1,$D(^DGPT(PTF,"M",1,300)) S DGREC=^(300) F X=2:1:7 S:$P(DGREC,U,X) DR=DR_"300.0"_X_"///@;"
I DR]"" S DA=1,DA(1)=PTF D ^DIE
K DGPTFP,DGREC,DA,DR,DIE,Y,X,DGEX Q
;
LE ;entry point for PTF record update
Q ;ihs/cmi/maw 02/08/2012 patch 1015 still no PTF in IHS
I '$D(ZTQUEUED),'$G(DGQUIET) W !,"Updating PTF Record #",PTF,"..."
K ^UTILITY($J,"T")
S DGPREV=$O(^DGPM("ATS",DFN,DGPMCA,0)),DGDT=$S($D(^DGPM(+$P(DGPMAN,"^",17),0)):+^(0),1:"")
D NOTS:'DGPREV
I DGPREV S:DGDT T(DGDT)="" D ^DGPTTS1,VARS^DGPTSUDO
K DGDR,L,MN,DIE,DIC,DIS,D,J,ADM,%DT,DR,I1,LL,NOW,T,TRN,ZTSK,L1,L2,T1,T2,TD,TDD,I,PTN,NTR,DA,NX,NXX,PR,DGTNX,DGTEMP,DGTPR,LOL,LOP,Z,Y,A,B,C,DGAD,DGDEL,X1,X2,^UTILITY($J,"T"),DGTR,DGREC,DGDT1,DGTLOS
F DA=0:0 S DA=$O(^DGPT(PTF,"P",DA)) Q:DA'>0 I $D(^DGPT(PTF,"P",DA,0)) D BS^DGPTFM6 S DIE="^DGPT("_PTF_",""P"",",DA(1)=PTF,DR="1///"_DGMOVM D ^DIE
D EN^DGPTTS3 I '$D(ZTQUEUED),'$G(DGQUIET) W "completed."
Q K DGDT,DA,DGP0,DGMSG,DGPREV,DGREC,DGMOVM,DIC,DIE,DR,V,X,Y Q
;
NTR S DGMSG="A Transfer on "_$TR($$FMTE^XLFDT(+DGMVA,"5DF")," ","0")_" was entered before the latest transfer. Please verify PTF #"_PTF_"."
S DGMSG1="New Facility Treating Specialty" D MSG^DGPTMSG1
Q
;
NOTS ;
S DIE="^DGPT("_PTF_",""M"",",DA(1)=PTF,DA=1,DR="2///@" D ^DIE
F DA=0:0 S DA=$O(^DGPT(PTF,"P",DA)) Q:DA'>0 I $D(^DGPT(PTF,"P",DA,0)) S DIE="^DGPT("_PTF_",""P"",",DA(1)=PTF,DR="1///@" D ^DIE
Q
;
DGDT ; -- get first ts before dc date
N X S X=$P(9999999.999999-DGDT,".")
F DGPREV=0:0 S DGPREV=+$O(^DGPM("ATS",DFN,DGPMCA,DGPREV)) Q:$P(DGPREV,".")'=X
Q
;
CA ; -- determine CA info
S DGPMCA=$S($P(DGPMP,"^",14):$P(DGPMP,"^",14),1:$P(DGPMA,"^",14))
S DGPMAN=$S($D(^DGPM(+DGPMCA,0)):^(0),1:""),DGMVT=$S($P(DGPMP,"^",2):$P(DGPMP,"^",2),1:$P(DGPMA,"^",2)),PTF=$P(DGPMAN,"^",16),DGADM=+DGPMAN
Q
DGPTTS ;ALB/AS/ADL - UPDATE FACILITY TREATING SPECIALTY/501 MOVEMENTS IN PTF ; 1/30/90 @12
+1 ;;5.3;Registration;**26,61,164,510,1015**;Aug 13, 1993;Build 21
+2 ;;ADL;Update for CSV Project;;Mar 28, 2003
+3 ;needs to be done - OERR link
+4 ;
EV ;entry point from event driver
+1 DO EV^DGPTTS0
+2 QUIT
+3 ;
DEL ;facility treating specialty has been deleted from ^DGPM
+1 SET DGPTFP=^UTILITY("DGPM",$JOB,6,DGMV,"PTFP")
+2 IF '$DATA(^DGPT(PTF,"M",+$PIECE(DGPTFP,"^",2),0))
GOTO DEL1
+3 KILL DA
SET DGREC=^(0)
SET DGEX=$SELECT($DATA(^(300)):^(300),1:"")
SET DA=$PIECE(DGPTFP,"^",2)
SET DA(1)=PTF
SET DIK="^DGPT("_DA(1)_",""M"","
DO ^DIK
KILL DA
+4 SET DGMSG=""
FOR X=5:1:15
IF X'=10
SET DGPTTMP=$$ICDDX^ICDCODE(+$PIECE(DGREC,U,X),$$GETDATE^ICDGTDRG(PTF))
SET DGMSG=DGMSG_$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2)_", ",1:"")
+5 IF DGMSG']""
GOTO DEL1
SET ^UTILITY($JOB,"DEL",$PIECE(DGPTFP,"^",2))=DGMSG
+6 ;-- save expanded codes
+7 SET DG1=""
+8 IF DGEX]""
FOR X=2:1:7
IF $PIECE(DGEX,U,X)]""
SET $PIECE(DG1,U,X)=$PIECE(DGEX,U,X)
+9 IF DG1]""
SET ^UTILITY($JOB,300,$PIECE(DGPTFP,U,2))=DG1
+10 KILL DGI
+11 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)
+12 SET DGMSG1="501 Movement Deletion"
DO MSG^DGPTMSG1
+13 ;
DEL1 SET X=^DPT(DFN,0)
SET DGMSG="A transfer between treating specialties for "_$PIECE(X,U,1)_" ("_$PIECE(X,U,9)_") on "_$TRANSLATE($$FMTE^XLFDT(+DGMVP,"5DF")," ","0")_" was deleted by "_$PIECE(^VA(200,+DUZ,0),U)_". Please verify PTF #"_PTF_"."
+1 SET DGMSG1="Facility Treating Specialty Deletion"
DO MSG^DGPTMSG1
+2 ;
+3 SET DR=""
IF $PIECE(DGPTFP,"^",3)=1
SET DGREC=^DGPT(PTF,"M",1,0)
FOR X=5:1:15
IF X'=10
IF $PIECE(DGREC,U,X)
SET DR=DR_X_"///@;"
+4 IF DR]""
SET DA(1)=PTF
SET DIE="^DGPT("_DA(1)_",""M"","
SET DA=1
DO ^DIE
+5 ;-- clean up expanded code data
+6 SET DR=""
IF $PIECE(DGPTFP,U,3)=1
IF $DATA(^DGPT(PTF,"M",1,300))
SET DGREC=^(300)
FOR X=2:1:7
IF $PIECE(DGREC,U,X)
SET DR=DR_"300.0"_X_"///@;"
+7 IF DR]""
SET DA=1
SET DA(1)=PTF
DO ^DIE
+8 KILL DGPTFP,DGREC,DA,DR,DIE,Y,X,DGEX
QUIT
+9 ;
LE ;entry point for PTF record update
+1 ;ihs/cmi/maw 02/08/2012 patch 1015 still no PTF in IHS
QUIT
+2 IF '$DATA(ZTQUEUED)
IF '$GET(DGQUIET)
WRITE !,"Updating PTF Record #",PTF,"..."
+3 KILL ^UTILITY($JOB,"T")
+4 SET DGPREV=$ORDER(^DGPM("ATS",DFN,DGPMCA,0))
SET DGDT=$SELECT($DATA(^DGPM(+$PIECE(DGPMAN,"^",17),0)):+^(0),1:"")
+5 IF 'DGPREV
DO NOTS
+6 IF DGPREV
IF DGDT
SET T(DGDT)=""
DO ^DGPTTS1
DO VARS^DGPTSUDO
+7 KILL DGDR,L,MN,DIE,DIC,DIS,D,J,ADM,%DT,DR,I1,LL,NOW,T,TRN,ZTSK,L1,L2,T1,T2,TD,TDD,I,PTN,NTR,DA,NX,NXX,PR,DGTNX,DGTEMP,DGTPR,LOL,LOP,Z,Y,A,B,C,DGAD,DGDEL,X1,X2,^UTILITY($JOB,"T"),DGTR,DGREC,DGDT1,DGTLOS
+8 FOR DA=0:0
SET DA=$ORDER(^DGPT(PTF,"P",DA))
IF DA'>0
QUIT
IF $DATA(^DGPT(PTF,"P",DA,0))
DO BS^DGPTFM6
SET DIE="^DGPT("_PTF_",""P"","
SET DA(1)=PTF
SET DR="1///"_DGMOVM
DO ^DIE
+9 DO EN^DGPTTS3
IF '$DATA(ZTQUEUED)
IF '$GET(DGQUIET)
WRITE "completed."
Q KILL DGDT,DA,DGP0,DGMSG,DGPREV,DGREC,DGMOVM,DIC,DIE,DR,V,X,Y
QUIT
+1 ;
NTR SET DGMSG="A Transfer on "_$TRANSLATE($$FMTE^XLFDT(+DGMVA,"5DF")," ","0")_" was entered before the latest transfer. Please verify PTF #"_PTF_"."
+1 SET DGMSG1="New Facility Treating Specialty"
DO MSG^DGPTMSG1
+2 QUIT
+3 ;
NOTS ;
+1 SET DIE="^DGPT("_PTF_",""M"","
SET DA(1)=PTF
SET DA=1
SET DR="2///@"
DO ^DIE
+2 FOR DA=0:0
SET DA=$ORDER(^DGPT(PTF,"P",DA))
IF DA'>0
QUIT
IF $DATA(^DGPT(PTF,"P",DA,0))
SET DIE="^DGPT("_PTF_",""P"","
SET DA(1)=PTF
SET DR="1///@"
DO ^DIE
+3 QUIT
+4 ;
DGDT ; -- get first ts before dc date
+1 NEW X
SET X=$PIECE(9999999.999999-DGDT,".")
+2 FOR DGPREV=0:0
SET DGPREV=+$ORDER(^DGPM("ATS",DFN,DGPMCA,DGPREV))
IF $PIECE(DGPREV,".")'=X
QUIT
+3 QUIT
+4 ;
CA ; -- determine CA info
+1 SET DGPMCA=$SELECT($PIECE(DGPMP,"^",14):$PIECE(DGPMP,"^",14),1:$PIECE(DGPMA,"^",14))
+2 SET DGPMAN=$SELECT($DATA(^DGPM(+DGPMCA,0)):^(0),1:"")
SET DGMVT=$SELECT($PIECE(DGPMP,"^",2):$PIECE(DGPMP,"^",2),1:$PIECE(DGPMA,"^",2))
SET PTF=$PIECE(DGPMAN,"^",16)
SET DGADM=+DGPMAN
+3 QUIT
