- DGPTTS1 ;ALB/AS/ADL/PLT - FACILITY TREATING SPECIALTY AND 501 MOVEMENTS, cont. ;6/3/15 11:13am
- ;;5.3;Registration;**26,64,418,510,478,850,884**;Aug 13, 1993;Build 31
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;ADL;Update for CSV Project;;Mar 28, 2003
- ;
- ;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)!($P(^(0),"^",17)=1) D ASIH^DGPTTS2 ;p-418
- ;
- 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
- 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)) ;^(DGDEL) in next line references global on this line
- 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)
- . N DGREC81,DGREC82
- . S DGREC=$S($D(^DGPT(PTF,"M",DG1,0)):^(0),1:""),DGREC81=$G(^(81)),DGREC82=$G(^(82))
- . D MSG
- . QUIT
- 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:"")
- S DGREC=$S($D(^UTILITY($J,"T",DGAD)):^(DGAD),$D(T("ADM")):T("ADM"),1:"")
- I DGREC,$D(^DGPM(+DGREC,0)) D
- .N DGFDA,DGMSG
- .S DGFDA(405,(+DGREC)_",",53)=1
- .D FILE^DIE("","DGFDA","DGMSG")
- 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) D I DGREC]"" K DA S DIK="^DGPT("_PTF_",""M"",",DA(1)=PTF,DA=DG1 D ^DIK K DA
- . N DGREC81,DGREC82
- . S DGREC=$S($D(^DGPT(PTF,"M",+DG1,0)):^(0),1:""),DGREC81=$G(^(81)),DGREC82=$G(^(82))
- . QUIT:DGREC=""
- . D MSG
- . QUIT
- S DA=DG2,DR="52///@;53///@",DIE="^DGPM(" D ^DIE Q
- ;
- MSG ;
- N EFFDATE,IMPDATE,DGPTDAT
- D EFFDATE^DGPTIC10(PTF)
- S DGMSG="",DGMSG81="",DGMSG82=""
- 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:"")
- 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:"")
- QUIT:DGMSG=""&(DGMSG81="")
- I DGMSG="" S DGMSG=DGMSG81 K DGMSG81
- S ^UTILITY($J,"DEL",DG1)=DGMSG,^(DG1,82)=DGMSG82 S:DGMSG81]"" ^(81)=DGMSG81
- ;-- 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,DGMSG81,DGMSG82 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTTS1 4958 printed Jan 18, 2025@03:54:25 Page 2
- 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
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;ADL;Update for CSV Project;;Mar 28, 2003
- +4 ;
- +5 ;build DGA array w/patient's last treat spec of the day as of 11:59 pm
- +6 ;
- 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 ;p-418
- SET DGPREV=0
- SET X=$SELECT($DATA(^DIC(42,+$PIECE(DGPMAN,"^",6),0)):$PIECE(^(0),"^",3),1:0)
- IF "^NH^D^"[(U_X_U)!($PIECE(^(0),"^",17)=1)
- 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 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 ;^(DGDEL) in next line references global on this line
- 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)
- Begin DoDot:1
- +11 NEW DGREC81,DGREC82
- +12 SET DGREC=$SELECT($DATA(^DGPT(PTF,"M",DG1,0)):^(0),1:"")
- SET DGREC81=$GET(^(81))
- SET DGREC82=$GET(^(82))
- +13 DO MSG
- +14 QUIT
- End DoDot:1
- 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)
- +15 KILL DGA
- if $DATA(T(+DGDT))
- KILL T(DGDT)
- +16 SET DGAD=+DGPMAN
- FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"T",I))
- if I'>0
- QUIT
- SET DGAD=I
- +17 SET DGREC1=$SELECT($DATA(^DGPT(PTF,"M",1,0)):^(0),1:"")
- +18 SET DGREC=$SELECT($DATA(^UTILITY($JOB,"T",DGAD)):^(DGAD),$DATA(T("ADM")):T("ADM"),1:"")
- +19 IF DGREC
- IF $DATA(^DGPM(+DGREC,0))
- Begin DoDot:1
- +20 NEW DGFDA,DGMSG
- +21 SET DGFDA(405,(+DGREC)_",",53)=1
- +22 DO FILE^DIE("","DGFDA","DGMSG")
- End DoDot:1
- +23 SET DGREC=$PIECE(DGREC,U,2)
- +24 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
- +25 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
- +26 KILL DGSAVE,DR,DGREC1
- DO ^DGPTTS2
- QUIT
- +27 ;
- DEL if $DATA(^UTILITY($JOB,"T",(9999999.999999-$EXTRACT(DGPREV,1,14))))
- QUIT
- +1 SET DG1=$PIECE(^DGPM(DG1,"PTF"),"^",2)
- Begin DoDot:1
- +2 NEW DGREC81,DGREC82
- +3 SET DGREC=$SELECT($DATA(^DGPT(PTF,"M",+DG1,0)):^(0),1:"")
- SET DGREC81=$GET(^(81))
- SET DGREC82=$GET(^(82))
- +4 if DGREC=""
- QUIT
- +5 DO MSG
- +6 QUIT
- End DoDot:1
- IF DGREC]""
- KILL DA
- SET DIK="^DGPT("_PTF_",""M"","
- SET DA(1)=PTF
- SET DA=DG1
- DO ^DIK
- KILL DA
- +7 SET DA=DG2
- SET DR="52///@;53///@"
- SET DIE="^DGPM("
- DO ^DIE
- QUIT
- +8 ;
- MSG ;
- +1 NEW EFFDATE,IMPDATE,DGPTDAT
- +2 DO EFFDATE^DGPTIC10(PTF)
- +3 SET DGMSG=""
- SET DGMSG81=""
- SET DGMSG82=""
- +4 FOR X=5:1:15
- IF X'=10
- SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DGREC,U,X),EFFDATE)
- SET DGMSG=DGMSG_$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2)_", ",1:"")
- SET DGMSG82=DGMSG82_$SELECT(+DGPTTMP>0:$PIECE(DGREC82,U,X-4-(X>10))_", ",1:"")
- +5 FOR X=1:1:15
- SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DGREC81,U,X),EFFDATE)
- SET DGMSG81=DGMSG81_$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2)_", ",1:"")
- SET DGMSG82=DGMSG82_$SELECT(+DGPTTMP>0:$PIECE(DGREC82,U,X+10)_", ",1:"")
- +6 if DGMSG=""&(DGMSG81="")
- QUIT
- +7 IF DGMSG=""
- SET DGMSG=DGMSG81
- KILL DGMSG81
- +8 SET ^UTILITY($JOB,"DEL",DG1)=DGMSG
- SET ^(DG1,82)=DGMSG82
- if DGMSG81]""
- SET ^(81)=DGMSG81
- +9 ;-- save expanded codes
- +10 SET DGMSG1=""
- +11 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)
- +12 if DGMSG1]""
- SET ^UTILITY($JOB,300,DG1)=DGMSG1
- +13 KILL DGMSG1
- +14 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)
- +15 if '$DATA(DGPMAN)
- SET DGPMAN=^DGPM(DGPMCA,0)
- DO MSG^DGPTMSG1
- +16 KILL DGEX,DGMSG81,DGMSG82
- QUIT