- IB20PT83 ;ALB/CPM - EXPORT ROUTINE 'DGPTTS' ; 14-FEB-94
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;
- DGPTTS ;ALB/AS - UPDATE FACILITY TREATING SPECIALTY/501 MOVEMENTS IN PTF ; 1/30/90 @12
- ;;5.3;Registration;**26**;Aug 13, 1993
- ;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 S:X'=10 DGMSG=DGMSG_$S($D(^ICD9(+$P(DGREC,U,X),0)):$P(^(0),U,1)_", ",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 "_$E(+DGMVP,4,5)_"/"_$E(+DGMVP,6,7)_"/"_$E(+DGMVP,2,3)_" 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
- W:'$D(ZTQUEUED) !,"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 W:'$D(ZTQUEUED) "completed."
- Q K DGDT,DA,DGP0,DGMSG,DGPREV,DGREC,DGMOVM,DIC,DIE,DR,V,X,Y Q
- ;
- NTR S DGMSG="A Transfer on "_$E(+DGMVA,4,5)_"/"_$E(+DGMVA,6,7)_"/"_$E(+DGMVA,2,3)_" 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT83 3491 printed Jan 18, 2025@03:06:43 Page 2
- IB20PT83 ;ALB/CPM - EXPORT ROUTINE 'DGPTTS' ; 14-FEB-94
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;
- DGPTTS ;ALB/AS - UPDATE FACILITY TREATING SPECIALTY/501 MOVEMENTS IN PTF ; 1/30/90 @12
- +1 ;;5.3;Registration;**26**;Aug 13, 1993
- +2 ;needs to be done - OERR link
- +3 ;
- 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 DGMSG=DGMSG_$SELECT($DATA(^ICD9(+$PIECE(DGREC,U,X),0)):$PIECE(^(0),U,1)_", ",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 "_$EXTRACT(+DGMVP,4,5)_"/"_$EXTRACT(+DGMVP,6,7)_"/"_$EXTRACT(+DGMVP,2,3)_" 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 if '$DATA(ZTQUEUED)
- WRITE !,"Updating PTF Record #",PTF,"..."
- KILL ^UTILITY($JOB,"T")
- +2 SET DGPREV=$ORDER(^DGPM("ATS",DFN,DGPMCA,0))
- SET DGDT=$SELECT($DATA(^DGPM(+$PIECE(DGPMAN,"^",17),0)):+^(0),1:"")
- +3 if 'DGPREV
- DO NOTS
- +4 IF DGPREV
- if DGDT
- SET T(DGDT)=""
- DO ^DGPTTS1
- DO VARS^DGPTSUDO
- +5 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
- +6 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
- +7 DO EN^DGPTTS3
- if '$DATA(ZTQUEUED)
- 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 "_$EXTRACT(+DGMVA,4,5)_"/"_$EXTRACT(+DGMVA,6,7)_"/"_$EXTRACT(+DGMVA,2,3)_" 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