- 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
