Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPTTS1

DGPTTS1.m

Go to the documentation of this file.
  1. DGPTTS1 ;ALB/AS/ADL/PLT - FACILITY TREATING SPECIALTY AND 501 MOVEMENTS, cont. ;6/3/15 11:13am
  1. ;;5.3;Registration;**26,64,418,510,478,850,884**;Aug 13, 1993;Build 31
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;ADL;Update for CSV Project;;Mar 28, 2003
  1. ;
  1. ;build DGA array w/patient's last treat spec of the day as of 11:59 pm
  1. ;
  1. LOOP ;
  1. S DGNEXT=$O(^DGPM("ATS",DFN,DGPMCA,DGPREV))
  1. F DGNEXT=DGNEXT:0 Q:($P(DGPREV,".")'=$P(DGNEXT,"."))!('DGNEXT) S DGNEXT=$O(^DGPM("ATS",DFN,DGPMCA,DGNEXT))
  1. 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
  1. S DGPREV=0,X=$S($D(^DIC(42,+$P(DGPMAN,"^",6),0)):$P(^(0),"^",3),1:0) I "^NH^D^"[(U_X_U)!($P(^(0),"^",17)=1) D ASIH^DGPTTS2 ;p-418
  1. ;
  1. LOOP1 ; -- compare specs between mvts ; sort out xfr if spec did't change
  1. S DGSAVE=DGPREV
  1. 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
  1. ;
  1. ; -- is mvt during adm
  1. 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
  1. ;
  1. ; build ^UTILITY for mvts whose spec changed
  1. 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:"")
  1. LOOPQ I $O(DGA(DGPREV)) G LOOP1
  1. ;
  1. ; look for mvts in ^DGPM that have a PTF mvt # entry
  1. ; but not in ^UTILITY. If any are found, delete from ^DGPT.
  1. 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
  1. ;
  1. 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:"")
  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
  1. ;
  1. S DGDEL=$O(^UTILITY($J,"T",0)) ;^(DGDEL) in next line references global on this line
  1. I DGDEL S T(DGDEL)=^(DGDEL),DG1=$P(T(DGDEL),"^",3) I DG1 S T(DGDEL)=$P(T(DGDEL),U,1,2) D 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)
  1. . N DGREC81,DGREC82
  1. . S DGREC=$S($D(^DGPT(PTF,"M",DG1,0)):^(0),1:""),DGREC81=$G(^(81)),DGREC82=$G(^(82))
  1. . D MSG
  1. . QUIT
  1. K DGA K:$D(T(+DGDT)) T(DGDT)
  1. S DGAD=+DGPMAN F I=0:0 S I=$O(^UTILITY($J,"T",I)) Q:I'>0 S DGAD=I
  1. S DGREC1=$S($D(^DGPT(PTF,"M",1,0)):^(0),1:"")
  1. S DGREC=$S($D(^UTILITY($J,"T",DGAD)):^(DGAD),$D(T("ADM")):T("ADM"),1:"")
  1. I DGREC,$D(^DGPM(+DGREC,0)) D
  1. .N DGFDA,DGMSG
  1. .S DGFDA(405,(+DGREC)_",",53)=1
  1. .D FILE^DIE("","DGFDA","DGMSG")
  1. S DGREC=$P(DGREC,U,2)
  1. 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
  1. 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
  1. K DGSAVE,DR,DGREC1 D ^DGPTTS2 Q
  1. ;
  1. DEL Q:$D(^UTILITY($J,"T",(9999999.999999-$E(DGPREV,1,14))))
  1. S DG1=$P(^DGPM(DG1,"PTF"),"^",2) D I DGREC]"" K DA S DIK="^DGPT("_PTF_",""M"",",DA(1)=PTF,DA=DG1 D ^DIK K DA
  1. . N DGREC81,DGREC82
  1. . S DGREC=$S($D(^DGPT(PTF,"M",+DG1,0)):^(0),1:""),DGREC81=$G(^(81)),DGREC82=$G(^(82))
  1. . QUIT:DGREC=""
  1. . D MSG
  1. . QUIT
  1. S DA=DG2,DR="52///@;53///@",DIE="^DGPM(" D ^DIE Q
  1. ;
  1. MSG ;
  1. N EFFDATE,IMPDATE,DGPTDAT
  1. D EFFDATE^DGPTIC10(PTF)
  1. S DGMSG="",DGMSG81="",DGMSG82=""
  1. F X=5:1:15 I X'=10 S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGREC,U,X),EFFDATE),DGMSG=DGMSG_$S(+DGPTTMP>0:$P(DGPTTMP,U,2)_", ",1:""),DGMSG82=DGMSG82_$S(+DGPTTMP>0:$P(DGREC82,U,X-4-(X>10))_", ",1:"")
  1. F X=1:1:15 S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGREC81,U,X),EFFDATE),DGMSG81=DGMSG81_$S(+DGPTTMP>0:$P(DGPTTMP,U,2)_", ",1:""),DGMSG82=DGMSG82_$S(+DGPTTMP>0:$P(DGREC82,U,X+10)_", ",1:"")
  1. QUIT:DGMSG=""&(DGMSG81="")
  1. I DGMSG="" S DGMSG=DGMSG81 K DGMSG81
  1. S ^UTILITY($J,"DEL",DG1)=DGMSG,^(DG1,82)=DGMSG82 S:DGMSG81]"" ^(81)=DGMSG81
  1. ;-- save expanded codes
  1. S DGMSG1=""
  1. 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)
  1. S:DGMSG1]"" ^UTILITY($J,300,DG1)=DGMSG1
  1. K DGMSG1
  1. 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)
  1. S:'$D(DGPMAN) DGPMAN=^DGPM(DGPMCA,0) D MSG^DGPTMSG1
  1. K DGEX,DGMSG81,DGMSG82 Q