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

DGPTFQWK.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  S (DGPTF,DA)=PTF,DIE="^DGPT(",DR="[DGQWK"_$S('DGPTFE:"]",1:"F]") W !,"* editing 101 & 701 transactions" D ^DIE
  1.  S DGCODSYS=$$CODESYS^DGPTIC10(PTF),(DGPTF,DA)=PTF,DIE="^DGPT(",DR=$S(DGCODSYS="ICD10":"[DG701-10D]",1:"[DG701]")
  1.  ;used only for roll back icd10 to icd9
  1.  I DR="[DG701]",$P($G(^DGPT(PTF,71)),U,4,999)'?."^" S DR="[DG701-10D]"
  1.  D ^DIE
  1.  ;
  1.  W !,"* editing 501 transactions"
  1.  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
  1.  . I 'DGPTFE S DR=$S(DGCODSYS="ICD10":"[DG501-10D]",1:"[DG501]") QUIT
  1.  . S DR=$S(DGCODSYS="ICD10":"[DG501F-10D]",1:"[DG501F]")
  1.  . QUIT
  1.  K DIC,DA,DR,DIE,DGCODSYS,DGXX,DGTYPE
  1.  ;
  1.  W !,"* editing 401 transactions"
  1.  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
  1.  I '$P(^DGPT(PTF,0),U,4) W !,"* editing 801 transactions" D S801
  1.  K DIC,DA,DR,DIE
  1.  W !,"* editing 601 transactions"
  1.  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
  1.  K DIC,DA,DR,DIE
  1.  I '$P(^DGPT(PTF,0),"^",4)&('DGST) W !,"  Updating TRANSFER DRGs" S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO
  1.  K DGM,DA,DGMOVENO,DIC,DIE,DR,Y,DGPTF,DGJUMP Q
  1.  ;
  1. S501 ;-- set up 501 
  1.  ;set screen transaction identity
  1.  S X1="^501"
  1.  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
  1.  K DA,DIC
  1.  Q
  1.  ;
  1. S401 ;-- set up 401
  1.  ;set screen transaction identity
  1.  S X1="^401"
  1.  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
  1.  K DA,DIC
  1.  Q
  1.  ;
  1. S601 ;-- set up 601
  1.  ;set screen transaction identity
  1.  S X1="^601"
  1.  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
  1.  K DA,DIC
  1.  Q
  1. S801 ;-- set up 801
  1.  ;set screen transaction identity
  1.  S X1="^801"
  1.  F  D  D REQ:$D(PSIEN) Q:$G(RFL)=1!(Y<0)  D PCE
  1.  .S DIC("A")="Select 801 CPT DATE/TIME: "
  1.  .S DA(1)=PTF,DIC(0)="AEQLZ",DIC="^DGPT("_PTF_",""C"",",DLAYGO=45
  1.  .S:'$D(^DGPT(PTF,"C",0)) ^(0)="^45.06^^" D ^DIC
  1.  .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
  1.  .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
  1.  .S DGI=0,DR=".01;" D CL^SDCO21(DFN,DGPRD,"",.SDCLY) D  S Y=1
  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
  1.  ..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
  1.  ..S Y=1
  1.  ..Q
  1.  .Q
  1.  K DR,DIE,DIC,DA,DGI,DGJUMP,DGPRD,DLAYGO,RFL Q
  1. REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS.  RECORDS MISSING ONE OR MORE REQUIRED FIELDS ARE DELETED.
  1.  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
  1.  .D ^DIK K DA W !!,"No CPT records have been filed because no performing provider was specified." S RFL=1
  1.  S (I,FCPT)=0 D RESEQ^DGPTFM3(PTF)
  1.  F J=1:1 S I=$O(^DGCPT(46,"C",PTF,I)) Q:'I  D:+^DGCPT(46,I,1)=DGPRD&'$G(^(9))
  1.  .I $P(^DGCPT(46,I,0),U,4) S FCPT=1 Q
  1.  .S DA=I,DIK="^DGCPT(46,",CPT=+^DGCPT(46,I,0) D ^DIK
  1.  .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."
  1.  .S RFL=2
  1.  I FCPT K FCPT,I,J,N G REQQ
  1.  S DA(1)=PTF,DA=PSIEN,DIK="^DGPT("_PTF_",""C"","
  1.  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
  1. REQQ ;D RESEQ^DGPTFM3(PTF)
  1.  Q
  1. SED S DR=".14////"_DGPRD_";.16////"_PTF_";",DA=+Y,DIE="^DGCPT(46,"
  1.  S REC=PTF D SDR^DGPTFM21,FMDIE Q
  1. PCE S DIR("A")="Send record to PCE? ",DIR(0)="S^Y:YES;N:NO",DIR("B")="NO"
  1.  D ^DIR K DIR Q:Y="N"!$D(DIRUT)
  1.  D MOB^DGPTFM2 S RES=$$DATA2PCE^DGAPI1(DFN,PTF,DGZP)
  1.  I RES=1 L -^DGPT(PTF) W !,"PTF Record sent to PCE" H 2 Q
  1.  W @IOF
  1.  W !,"The PTF Record may not have been filed in PCE due to errors."
  1.  W !,"Press return to continue." R X:DTIME
  1.  L -^DGPT(PTF) Q
  1. FMDIE L +^DGPT(45,REC):2
  1.  I  D ^DIE S RES=$$DELVFILE^DGAPI1(DFN,PTF,DGZP) L -^DGPT(45,REC) Q
  1. ERR W !,"CPT record is being edited by another user" K DIE,REC S ERRFKG=1 H 2 Q