DGPTFQWK ;ALB/AS/PLT - QUICK/LOAD PTF DATA ;7/21/05 2:44pm
;;5.3;Registration;**517,594,635,729,850,884**;Aug 13, 1993;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
S (DGPTF,DA)=PTF,DIE="^DGPT(",DR="[DGQWK"_$S('DGPTFE:"]",1:"F]") W !,"* editing 101 & 701 transactions" D ^DIE
S DGCODSYS=$$CODESYS^DGPTIC10(PTF),(DGPTF,DA)=PTF,DIE="^DGPT(",DR=$S(DGCODSYS="ICD10":"[DG701-10D]",1:"[DG701]")
;used only for roll back icd10 to icd9
I DR="[DG701]",$P($G(^DGPT(PTF,71)),U,4,999)'?."^" S DR="[DG701-10D]"
D ^DIE
;
W !,"* editing 501 transactions"
F DGM=0:0 D S501 Q:Y'>0 K DA S (DGPTF,DA)=PTF S DGMOV=+Y,DGJUMP=$S('DGPTFE:"",1:"1-2"),DGCODSYS=$$CODESYS^DGPTIC10(PTF) D S DIE="^DGPT(" D ^DIE,CHK501^DGPTSCAN K DGMOV
. I 'DGPTFE S DR=$S(DGCODSYS="ICD10":"[DG501-10D]",1:"[DG501]") QUIT
. S DR=$S(DGCODSYS="ICD10":"[DG501F-10D]",1:"[DG501F]")
. QUIT
K DIC,DA,DR,DIE,DGCODSYS,DGXX,DGTYPE
;
W !,"* editing 401 transactions"
F DGM=0:0 D S401 Q:Y'>0 K DA S DGSUR=+Y,DGJUMP="1-2",DGCODSYS=$$CODESYS^DGPTIC10(PTF),DR=$S(DGCODSYS="ICD10":"[DG401-10P]",1:"[DG401]"),DIE="^DGPT(",(DA,DGPTF)=PTF D ^DIE,CHK401^DGPTSCAN K DGSUR
I '$P(^DGPT(PTF,0),U,4) W !,"* editing 801 transactions" D S801
K DIC,DA,DR,DIE
W !,"* editing 601 transactions"
F DGM=0:0 S DGZP=1 D S601 Q:Y'>0 K DA S P(DGZP,1)=+Y,DGJUMP="1-2",DGCODSYS=$$CODESYS^DGPTIC10(PTF),DR=$S(DGCODSYS="ICD10":"[DG601-10P]",1:"[DG601]"),DIE="^DGPT(",(DA,DGPTF)=PTF D ^DIE,CHK601^DGPTSCAN K P
K DIC,DA,DR,DIE
I '$P(^DGPT(PTF,0),"^",4)&('DGST) W !," Updating TRANSFER DRGs" S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO
K DGM,DA,DGMOVENO,DIC,DIE,DR,Y,DGPTF,DGJUMP Q
;
S501 ;-- set up 501
;set screen transaction identity
S X1="^501"
S DA(1)=PTF,DIC("A")="Select 501 MOVEMENT NUMBER: ",DIC(0)="AEQ",DIC="^DGPT("_PTF_",""M""," S:'$D(^DGPT(PTF,"M",0)) ^(0)="^45.02AI^^" D ^DIC
K DA,DIC
Q
;
S401 ;-- set up 401
;set screen transaction identity
S X1="^401"
S DA(1)=PTF,DIC("A")="Select 401 SURGERY DATE: ",DIC(0)="AEQL",DIC="^DGPT("_PTF_",""S""," S:'$D(^DGPT(PTF,"S",0)) ^(0)="^45.01DA^^" D ^DIC
K DA,DIC
Q
;
S601 ;-- set up 601
;set screen transaction identity
S X1="^601"
S DA(1)=PTF,DIC("A")="Select 601 PROCEDURE DATE: ",DIC(0)="AEQL",DIC="^DGPT("_PTF_",""P""," S:'$D(^DGPT(PTF,"P",0)) ^(0)="^45.05DA^^" D ^DIC
K DA,DIC
Q
S801 ;-- set up 801
;set screen transaction identity
S X1="^801"
F D D REQ:$D(PSIEN) Q:$G(RFL)=1!(Y<0) D PCE
.S DIC("A")="Select 801 CPT DATE/TIME: "
.S DA(1)=PTF,DIC(0)="AEQLZ",DIC="^DGPT("_PTF_",""C"",",DLAYGO=45
.S:'$D(^DGPT(PTF,"C",0)) ^(0)="^45.06^^" D ^DIC
.K DA,DIC,PSIEN Q:Y'>0 S DGPRD=+Y(0),DGPSM=+Y D MOB^DGPTFM2 I $P(DGZPRF,U,3) F I=1:1:$P(DGZPRF,U,3) S:DGZPRF(I,0)=DGPSM DGZP=I
.S (DA(1),REC)=PTF,DIE="^DGPT("_PTF_",""C"",",(DA,PSIEN)=DGZPRF(DGZP,0),DR=".02;.03;.05" D FMDIE I $D(Y)>9!$D(DTOUT) S Y=-1 Q
.S DGI=0,DR=".01;" D CL^SDCO21(DFN,DGPRD,"",.SDCLY) D S Y=1
..F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 I +^DGCPT(46,DGI,1)=+DGZPRF(DGZP)&'$D(^(9)) S (DA,REC)=DGI,DR=".01;",DIE="^DGCPT(46," D GETINFO^DGPTFM21
..F S DA=PTF,DIC="^DGCPT(46,",DIC(0)="AELQMZ",DLAYGO=46,DIC("S")="D EN6^DGPTFJC I 'DGER" D ^DIC K DIC Q:Y'>0 D SED^DGPTFM2
..S Y=1
..Q
.Q
K DR,DIE,DIC,DA,DGI,DGJUMP,DGPRD,DLAYGO,RFL Q
REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS. RECORDS MISSING ONE OR MORE REQUIRED FIELDS ARE DELETED.
S RFL=0 I '$P(^DGPT(PTF,"C",PSIEN,0),U,3) S DA(1)=PTF,DA=DGPSM,DIK="^DGPT("_PTF_",""C""," D G REQQ
.D ^DIK K DA W !!,"No CPT records have been filed because no performing provider was specified." S RFL=1
S (I,FCPT)=0 D RESEQ^DGPTFM3(PTF)
F J=1:1 S I=$O(^DGCPT(46,"C",PTF,I)) Q:'I D:+^DGCPT(46,I,1)=DGPRD&'$G(^(9))
.I $P(^DGCPT(46,I,0),U,4) S FCPT=1 Q
.S DA=I,DIK="^DGCPT(46,",CPT=+^DGCPT(46,I,0) D ^DIK
.W !!,"CPT " S N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)) W $P(N,U,2)," ",$P(N,U,3)," not filed because no diagnosis 1 was entered."
.S RFL=2
I FCPT K FCPT,I,J,N G REQQ
S DA(1)=PTF,DA=PSIEN,DIK="^DGPT("_PTF_",""C"","
D ^DIK K DA W !!,"No CPT records have been filed because no CPT codes were filed." S RFL=1 K FCPT,I,J,N
REQQ ;D RESEQ^DGPTFM3(PTF)
Q
SED S DR=".14////"_DGPRD_";.16////"_PTF_";",DA=+Y,DIE="^DGCPT(46,"
S REC=PTF D SDR^DGPTFM21,FMDIE Q
PCE S DIR("A")="Send record to PCE? ",DIR(0)="S^Y:YES;N:NO",DIR("B")="NO"
D ^DIR K DIR Q:Y="N"!$D(DIRUT)
D MOB^DGPTFM2 S RES=$$DATA2PCE^DGAPI1(DFN,PTF,DGZP)
I RES=1 L -^DGPT(PTF) W !,"PTF Record sent to PCE" H 2 Q
W @IOF
W !,"The PTF Record may not have been filed in PCE due to errors."
W !,"Press return to continue." R X:DTIME
L -^DGPT(PTF) Q
FMDIE L +^DGPT(45,REC):2
I D ^DIE S RES=$$DELVFILE^DGAPI1(DFN,PTF,DGZP) L -^DGPT(45,REC) Q
ERR W !,"CPT record is being edited by another user" K DIE,REC S ERRFKG=1 H 2 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFQWK 4853 printed Apr 09, 2024@21:51:58 Page 2
DGPTFQWK ;ALB/AS/PLT - QUICK/LOAD PTF DATA ;7/21/05 2:44pm
+1 ;;5.3;Registration;**517,594,635,729,850,884**;Aug 13, 1993;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 SET (DGPTF,DA)=PTF
SET DIE="^DGPT("
SET DR="[DGQWK"_$SELECT('DGPTFE:"]",1:"F]")
WRITE !,"* editing 101 & 701 transactions"
DO ^DIE
+5 SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
SET (DGPTF,DA)=PTF
SET DIE="^DGPT("
SET DR=$SELECT(DGCODSYS="ICD10":"[DG701-10D]",1:"[DG701]")
+6 ;used only for roll back icd10 to icd9
+7 IF DR="[DG701]"
IF $PIECE($GET(^DGPT(PTF,71)),U,4,999)'?."^"
SET DR="[DG701-10D]"
+8 DO ^DIE
+9 ;
+10 WRITE !,"* editing 501 transactions"
+11 FOR DGM=0:0
DO S501
if Y'>0
QUIT
KILL DA
SET (DGPTF,DA)=PTF
SET DGMOV=+Y
SET DGJUMP=$SELECT('DGPTFE:"",1:"1-2")
SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
Begin DoDot:1
+12 IF 'DGPTFE
SET DR=$SELECT(DGCODSYS="ICD10":"[DG501-10D]",1:"[DG501]")
QUIT
+13 SET DR=$SELECT(DGCODSYS="ICD10":"[DG501F-10D]",1:"[DG501F]")
+14 QUIT
End DoDot:1
SET DIE="^DGPT("
DO ^DIE
DO CHK501^DGPTSCAN
KILL DGMOV
+15 KILL DIC,DA,DR,DIE,DGCODSYS,DGXX,DGTYPE
+16 ;
+17 WRITE !,"* editing 401 transactions"
+18 FOR DGM=0:0
DO S401
if Y'>0
QUIT
KILL DA
SET DGSUR=+Y
SET DGJUMP="1-2"
SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
SET DR=$SELECT(DGCODSYS="ICD10":"[DG401-10P]",1:"[DG401]")
SET DIE="^DGPT("
SET (DA,DGPTF)=PTF
DO ^DIE
DO CHK401^DGPTSCAN
KILL DGSUR
+19 IF '$PIECE(^DGPT(PTF,0),U,4)
WRITE !,"* editing 801 transactions"
DO S801
+20 KILL DIC,DA,DR,DIE
+21 WRITE !,"* editing 601 transactions"
+22 FOR DGM=0:0
SET DGZP=1
DO S601
if Y'>0
QUIT
KILL DA
SET P(DGZP,1)=+Y
SET DGJUMP="1-2"
SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
SET DR=$SELECT(DGCODSYS="ICD10":"[DG601-10P]",1:"[DG601]")
SET DIE="^DGPT("
SET (DA,DGPTF)=PTF
DO ^DIE
DO CHK601^DGPTSCAN
KILL P
+23 KILL DIC,DA,DR,DIE
+24 IF '$PIECE(^DGPT(PTF,0),"^",4)&('DGST)
WRITE !," Updating TRANSFER DRGs"
SET DGADM=$PIECE(^DGPT(PTF,0),U,2)
DO SUDO1^DGPTSUDO
+25 KILL DGM,DA,DGMOVENO,DIC,DIE,DR,Y,DGPTF,DGJUMP
QUIT
+26 ;
S501 ;-- set up 501
+1 ;set screen transaction identity
+2 SET X1="^501"
+3 SET DA(1)=PTF
SET DIC("A")="Select 501 MOVEMENT NUMBER: "
SET DIC(0)="AEQ"
SET DIC="^DGPT("_PTF_",""M"","
if '$DATA(^DGPT(PTF,"M",0))
SET ^(0)="^45.02AI^^"
DO ^DIC
+4 KILL DA,DIC
+5 QUIT
+6 ;
S401 ;-- set up 401
+1 ;set screen transaction identity
+2 SET X1="^401"
+3 SET DA(1)=PTF
SET DIC("A")="Select 401 SURGERY DATE: "
SET DIC(0)="AEQL"
SET DIC="^DGPT("_PTF_",""S"","
if '$DATA(^DGPT(PTF,"S",0))
SET ^(0)="^45.01DA^^"
DO ^DIC
+4 KILL DA,DIC
+5 QUIT
+6 ;
S601 ;-- set up 601
+1 ;set screen transaction identity
+2 SET X1="^601"
+3 SET DA(1)=PTF
SET DIC("A")="Select 601 PROCEDURE DATE: "
SET DIC(0)="AEQL"
SET DIC="^DGPT("_PTF_",""P"","
if '$DATA(^DGPT(PTF,"P",0))
SET ^(0)="^45.05DA^^"
DO ^DIC
+4 KILL DA,DIC
+5 QUIT
S801 ;-- set up 801
+1 ;set screen transaction identity
+2 SET X1="^801"
+3 FOR
Begin DoDot:1
+4 SET DIC("A")="Select 801 CPT DATE/TIME: "
+5 SET DA(1)=PTF
SET DIC(0)="AEQLZ"
SET DIC="^DGPT("_PTF_",""C"","
SET DLAYGO=45
+6 if '$DATA(^DGPT(PTF,"C",0))
SET ^(0)="^45.06^^"
DO ^DIC
+7 KILL DA,DIC,PSIEN
if Y'>0
QUIT
SET DGPRD=+Y(0)
SET DGPSM=+Y
DO MOB^DGPTFM2
IF $PIECE(DGZPRF,U,3)
FOR I=1:1:$PIECE(DGZPRF,U,3)
if DGZPRF(I,0)=DGPSM
SET DGZP=I
+8 SET (DA(1),REC)=PTF
SET DIE="^DGPT("_PTF_",""C"","
SET (DA,PSIEN)=DGZPRF(DGZP,0)
SET DR=".02;.03;.05"
DO FMDIE
IF $DATA(Y)>9!$DATA(DTOUT)
SET Y=-1
QUIT
+9 SET DGI=0
SET DR=".01;"
DO CL^SDCO21(DFN,DGPRD,"",.SDCLY)
Begin DoDot:2
+10 FOR
SET DGI=$ORDER(^DGCPT(46,"C",PTF,DGI))
if DGI'>0
QUIT
IF +^DGCPT(46,DGI,1)=+DGZPRF(DGZP)&'$DATA(^(9))
SET (DA,REC)=DGI
SET DR=".01;"
SET DIE="^DGCPT(46,"
DO GETINFO^DGPTFM21
+11 FOR
SET DA=PTF
SET DIC="^DGCPT(46,"
SET DIC(0)="AELQMZ"
SET DLAYGO=46
SET DIC("S")="D EN6^DGPTFJC I 'DGER"
DO ^DIC
KILL DIC
if Y'>0
QUIT
DO SED^DGPTFM2
+12 SET Y=1
+13 QUIT
End DoDot:2
SET Y=1
+14 QUIT
End DoDot:1
if $DATA(PSIEN)
DO REQ
if $GET(RFL)=1!(Y<0)
QUIT
DO PCE
+15 KILL DR,DIE,DIC,DA,DGI,DGJUMP,DGPRD,DLAYGO,RFL
QUIT
REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS. RECORDS MISSING ONE OR MORE REQUIRED FIELDS ARE DELETED.
+1 SET RFL=0
IF '$PIECE(^DGPT(PTF,"C",PSIEN,0),U,3)
SET DA(1)=PTF
SET DA=DGPSM
SET DIK="^DGPT("_PTF_",""C"","
Begin DoDot:1
+2 DO ^DIK
KILL DA
WRITE !!,"No CPT records have been filed because no performing provider was specified."
SET RFL=1
End DoDot:1
GOTO REQQ
+3 SET (I,FCPT)=0
DO RESEQ^DGPTFM3(PTF)
+4 FOR J=1:1
SET I=$ORDER(^DGCPT(46,"C",PTF,I))
if 'I
QUIT
if +^DGCPT(46,I,1)=DGPRD&'$GET(^(9))
Begin DoDot:1
+5 IF $PIECE(^DGCPT(46,I,0),U,4)
SET FCPT=1
QUIT
+6 SET DA=I
SET DIK="^DGCPT(46,"
SET CPT=+^DGCPT(46,I,0)
DO ^DIK
+7 WRITE !!,"CPT "
SET N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF))
WRITE $PIECE(N,U,2)," ",$PIECE(N,U,3)," not filed because no diagnosis 1 was entered."
+8 SET RFL=2
End DoDot:1
+9 IF FCPT
KILL FCPT,I,J,N
GOTO REQQ
+10 SET DA(1)=PTF
SET DA=PSIEN
SET DIK="^DGPT("_PTF_",""C"","
+11 DO ^DIK
KILL DA
WRITE !!,"No CPT records have been filed because no CPT codes were filed."
SET RFL=1
KILL FCPT,I,J,N
REQQ ;D RESEQ^DGPTFM3(PTF)
+1 QUIT
SED SET DR=".14////"_DGPRD_";.16////"_PTF_";"
SET DA=+Y
SET DIE="^DGCPT(46,"
+1 SET REC=PTF
DO SDR^DGPTFM21
DO FMDIE
QUIT
PCE SET DIR("A")="Send record to PCE? "
SET DIR(0)="S^Y:YES;N:NO"
SET DIR("B")="NO"
+1 DO ^DIR
KILL DIR
if Y="N"!$DATA(DIRUT)
QUIT
+2 DO MOB^DGPTFM2
SET RES=$$DATA2PCE^DGAPI1(DFN,PTF,DGZP)
+3 IF RES=1
LOCK -^DGPT(PTF)
WRITE !,"PTF Record sent to PCE"
HANG 2
QUIT
+4 WRITE @IOF
+5 WRITE !,"The PTF Record may not have been filed in PCE due to errors."
+6 WRITE !,"Press return to continue."
READ X:DTIME
+7 LOCK -^DGPT(PTF)
QUIT
FMDIE LOCK +^DGPT(45,REC):2
+1 IF $TEST
DO ^DIE
SET RES=$$DELVFILE^DGAPI1(DFN,PTF,DGZP)
LOCK -^DGPT(45,REC)
QUIT
ERR WRITE !,"CPT record is being edited by another user"
KILL DIE,REC
SET ERRFKG=1
HANG 2
QUIT
