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

PXKMAIN1.m

Go to the documentation of this file. 
  1. PXKMAIN1 ;ISL/JVS,ISA/Zoltan - Main Routine for Data Capture ;Jul 26, 2021@09:35:17
  1.  ;;1.0;PCE PATIENT CARE ENCOUNTER;**22,73,124,178,210,216,211,217**;Aug 12, 1996;Build 134
  1.  ;+This routine is responsible for:
  1.  ;+ - creating new entries in PCE files,
  1.  ;+ - processing modifications to existing entries,
  1.  ;+ - deleting entries,
  1.  ;+ - ensuring all required variables are present,
  1.  ;+ - setting both Audit fields (EDITED FLAG and AUDIT TRAIL),
  1.  ;+ - checking for duplicate entries,
  1.  ;+ - some error reporting.
  1.  ;+
  1.  ;+LOCAL VARIABLE LIST
  1.  ;+ MOST VARIABLES ARE DEFINED AT THE TOP OF  PXKMAIN
  1.  ;+ PXKSEQ   = Sequence number in PXK TMP global
  1.  ;+ PXKCAT   = Category of entry (CPT,MSR,VST...)
  1.  ;+ PXKREF   = Root of temp global
  1.  ;+ PXKPIEN  = IEN of v file
  1.  ;+ PXKAUDIT = data located in the audit field of the v file
  1.  ;+ PXKER    = field data use to build the DR string (e.g., .04///^S X=$G()
  1.  ;+ PXKFLD   = field number gleaned from the file routines
  1.  ;+ PXKNOD   = same as the subscript in a global node
  1.  ;+ PXKPCE   = the piece where the data is found on that node
  1.  ;
  1.  ;
  1.  W !,"This is not an entry point" Q
  1. LOOP ;+Copy delimited strings into sub-arrays. PXKSUB is the node.
  1.  F PXKI=1:1:$L(PXKAFT(PXKSUB),"^") I $P(PXKAFT(PXKSUB),"^",PXKI)'="" S PXKAV(PXKSUB,PXKI)=$P(PXKAFT(PXKSUB),"^",PXKI)
  1.  F PXKI=1:1:$L(PXKBEF(PXKSUB),"^") I $P(PXKBEF(PXKSUB),"^",PXKI)'="" S PXKBV(PXKSUB,PXKI)=$P(PXKBEF(PXKSUB),"^",PXKI)
  1.  K PXKI,PXKJ ; Not sure if NEW would be OK.
  1.  I PXKCAT="CPT",PXKSUB=1 D LOOP^PXKMOD
  1.  Q
  1.  ;
  1. ERROR ;+Check for missing required fields
  1.  Q:$G(PXKAV(0,1))["@"!('$D(PXKAV(0,1)))
  1.  S PXKNOD=0,PXKPCE=0
  1.  D EN1^@PXKRTN
  1.  S PXKER=$P(PXKER," * ",1)
  1.  I PXKER="" Q
  1.  N PXJ,PXKFD,PXKFLD
  1.  F PXJ=1:1:$L(PXKER,",") D
  1.  . S PXJJ=$P(PXKER,",",PXJ)
  1.  . I '$D(PXKAV(PXKNOD,PXJJ)) D
  1.  .. S PXKPCE=PXJJ
  1.  .. D EN2^@PXKRTN
  1.  .. S PXKFLD=$P(PXKFD,"/",1)
  1.  .. S:PXKFLD["*" PXKFLD=$P(PXKFLD," * ",2)
  1.  .. S PXKERROR(PXKCAT,PXKSEQ,0,PXKFLD)="Missing Required Fields"
  1.  Q
  1.  ;
  1. CLEAN ;--Clean out the PXKAV array
  1.  S PXKJ=""
  1.  F  S PXKJ=$O(PXKBV(PXKJ)) Q:PXKJ=""  D
  1.  . I PXKCAT="IMM",PXKJ?1(1"2",1"3",1"11") D CLEAN^PXKIMM(PXKJ) Q
  1.  . S PXKI=""
  1.  . F  S PXKI=$O(PXKBV(PXKJ,PXKI)) Q:PXKI=""  D
  1.  . . I $G(PXKBV(PXKJ,PXKI))=$G(PXKAV(PXKJ,PXKI)) K PXKAV(PXKJ,PXKI)
  1.  K PXKI,PXKJ ; Not sure about NEW here.
  1.  Q
  1.  ;
  1. FILE ;+Create a new entry in file and get IEN
  1.  ;+This is the code that adds new entries to V-files
  1.  ;+and to the Visit file.
  1.  K DD,DO
  1.  S DIC=$P($T(GLOBAL^@PXKRTN),";;",2)_"("
  1.  S DIC(0)=""
  1.  S X=$G(PXKAV(0,1))
  1.  D FILE^DICN
  1.  S (PXKPIEN,DA)=+Y
  1.  S DR=""
  1.  K DIC,Y,X
  1.  I PXKCAT="IMM",PXKPIEN S PXVNEWIM=PXKPIEN S:$D(PXVNEWDA) PXVNEWDA=PXKPIEN ; PX*1*210
  1.  Q
  1.  ;
  1. AUD12 ;--Set both audit fields
  1.  S DR=""
  1.  S PXKAUDIT=$P($T(GLOBAL^@PXKRTN),";;",2)_"(DA,801)"
  1.  S PXKAUDIT=$P($G(@PXKAUDIT),"^",2)_PXKSORR_";"
  1.  I $L(PXKAUDIT,";")>5 S $P(PXKAUDIT,";",2,$L(PXKAUDIT,";"))="+;"_$P(PXKAUDIT,";",4,$L(PXKAUDIT,";")) ;PX*1*124   Change 8 to 5
  1.  S PXKNOD=801
  1.  S DR=""
  1.  F PXKPCE=1,2 D EN1^@PXKRTN S DR=DR_PXKER
  1.  I PXKCAT="IMM" D TMSTAMP
  1.  S PXKFVDLM=""
  1.  Q
  1.  ;
  1. AUD2 ;--Set second audit fields
  1.  S DR=""
  1.  S PXKAUDIT=$P($T(GLOBAL^@PXKRTN),";;",2)_"(DA,801)"
  1.  S PXKAUDIT=$P($G(@PXKAUDIT),"^",2)_PXKSORR_";"
  1.  I $L(PXKAUDIT,";")>5 S $P(PXKAUDIT,";",2,$L(PXKAUDIT,";"))="+;"_$P(PXKAUDIT,";",4,$L(PXKAUDIT,";")) ;PX*1*124   Change 8 to 5
  1.  S PXKNOD=801
  1.  S DR=""
  1.  S PXKPCE=2
  1.  D EN1^@PXKRTN
  1.  S DR=DR_PXKER
  1.  I PXKCAT="IMM" D TMSTAMP
  1.  S PXKFVDLM=""
  1.  Q
  1.  ;
  1. TMSTAMP ; set Timestamp
  1.  S PXKNOW=$$NOW^XLFDT
  1.  S PXKNOD=12
  1.  S PXKPCE=21
  1.  D EN1^@PXKRTN
  1.  S DR=DR_PXKER
  1.  Q
  1.  ;
  1. DRDIE ;--Set the DR string and DO DIE
  1.  I PXKCAT="VST" D UPD^PXKFVST Q
  1.  ;
  1.  S DIE=$P($T(GLOBAL^@PXKRTN),";;",2)_"(" K PXKPTR
  1.  S PXKLR=$P($T(GLOBAL^@PXKRTN),";;",2)_"(DA)"
  1.  ;
  1.  S PXKNOD=""
  1.  F  S PXKNOD=$O(PXKAV(PXKNOD)) Q:PXKNOD=""  D
  1.  . I PXKFGAD=1,PXKNOD=0 S PXKPCE=1 D
  1.  .. Q:PXKCAT'="CPT"
  1.  .. I $G(^TMP("PXK",$J,PXKCAT,PXKSEQ,"IEN"))=PXKPIEN S PXKPCE=3
  1.  . I PXKFGAD=1,PXKNOD'=0 S PXKPCE=0
  1.  . I PXKFGED=1 S PXKPCE=0
  1.  . I PXKCAT="CPT",PXKNOD=1 D  Q
  1.  .. D DIE
  1.  .. ;I $G(^TMP("PXK",$J,PXKCAT,PXKSEQ,"IEN"))]"" Q
  1.  .. D UPD^PXKMOD(PXKPIEN)
  1.  . ;
  1.  . I PXKCAT="IMM",PXKNOD?1(1"2",1"3",1"11") D DIE^PXKIMM Q
  1.  . ;
  1.  . F  S PXKPCE=$O(PXKAV(PXKNOD,PXKPCE)) Q:PXKPCE=""  D
  1.  ..D EN1^@PXKRTN
  1.  ..I $G(PXKER)'="" D
  1.  ...I PXKER["~" D
  1.  ....I $P(PXKER,"~",2)["A",PXKFGAD=1 S PXKER=$P(PXKER,"~") Q
  1.  ....I $P(PXKER,"~",2)'["A",PXKFGAD=1 S PXKER="" Q
  1.  ....I $P(PXKER,"~",2)["E",PXKFGED=1 S PXKER=$P(PXKER,"~") Q
  1.  ....I $P(PXKER,"~",2)'["E",PXKFGED=1 S PXKER="" Q
  1.  ...I +PXKER=0 D
  1.  ....I PXKAV(PXKNOD,PXKPCE)=+PXKAV(PXKNOD,PXKPCE) S PXKER=$P(PXKER," * ",2)
  1.  ....I PXKAV(PXKNOD,PXKPCE)'=+PXKAV(PXKNOD,PXKPCE) S PXKER=$P(PXKER," * ",3),PXKPTR(PXKPIEN,PXKNOD,PXKPCE)=""
  1.  ..I $G(PXKER)'="" S DR=DR_PXKER_"PXKAV("_PXKNOD_","_PXKPCE_"));"
  1.  ..I $L(DR)>200 D DIE
  1.  D DIE
  1.  K DIE,PXKLR,DIC(0)
  1.  D ER
  1.  Q
  1.  ;
  1. DIE ;Invoke FM ^DIE call.
  1.  D ^DIE
  1.  K DR
  1.  S DR=""
  1.  Q
  1.  ;
  1. DELETE ;+Use FM ^DIK call to delete entry identified by PXKPIEN.
  1.  ;
  1.  ; Make a copy of entry before deleting it
  1.  I $T(DELGBL^@PXKRTN)'="" D COPYDEL
  1.  ;
  1.  S DA=PXKPIEN
  1.  S DIK=$P($T(GLOBAL^@PXKRTN),";;",2)_"("
  1.  D ^DIK
  1.  K DIK
  1.  Q
  1.  ;
  1. COPYDEL ; Make a copy of entry
  1.  ;
  1.  N DA,DIC,DINUM,DIK,DO,PXDELGBL,PXGBL,PXKPDELIEN,PXTMP,X,Y
  1.  ;
  1.  S PXDELGBL=$P($T(DELGBL^@PXKRTN),";;",2)
  1.  I $E(PXDELGBL,1)'="^" Q
  1.  S PXGBL=$P($T(GLOBAL^@PXKRTN),";;",2)_"("
  1.  ;
  1.  ; add entry to deleted file
  1.  S PXTMP=$G(@(PXGBL_PXKPIEN_",0)"))
  1.  I $P(PXTMP,U,1)="" Q
  1.  S X=$P(PXTMP,U,1)
  1.  S DIC=PXDELGBL
  1.  S DIC(0)=""
  1.  L +@(PXDELGBL_PXKPIEN_")"):DILOCKTM
  1.  ; if possible, try to assign same IEN in deleted file
  1.  I '$D(@(PXDELGBL_PXKPIEN_")")) S DINUM=PXKPIEN
  1.  D FILE^DICN
  1.  L -@(PXDELGBL_PXKPIEN_")")
  1.  ;
  1.  ; Now copy the rest of the data.
  1.  S PXKPDELIEN=$P(Y,U,1)
  1.  I PXKPDELIEN'>0 Q
  1.  L +@(PXDELGBL_PXKPDELIEN_")"):DILOCKTM
  1.  M @(PXDELGBL_PXKPDELIEN_")")=@(PXGBL_PXKPIEN_")")
  1.  S @(PXDELGBL_PXKPDELIEN_",880)")=DUZ_U_$$NOW^XLFDT
  1.  S DIK=PXDELGBL
  1.  S DA=PXKPDELIEN
  1.  D IX1^DIK
  1.  L -@(PXDELGBL_PXKPDELIEN_")")
  1.  ;
  1.  Q
  1.  ;
  1. DUP ;+Code to check for duplicates
  1.  I PXKCAT="VST" Q
  1.  I PXKCAT="CPT" Q
  1.  I PXKCAT="HF" Q
  1.  N PXKRTN
  1.  I '$D(PXKPIEN) N PXKPIEN S PXKPIEN=""
  1.  S PXKNOD=0
  1.  S PXKPCE=0
  1.  S PXKRTN="PXKF"_PXKVCAT
  1.  S PXKVRTN=$P($T(GLOBAL^@PXKRTN),";;",2)
  1.  S PXJJJ=0
  1.  D EN1^@PXKRTN
  1.  I $P(PXKER," * ",3)'=0 D
  1.  .S PXKER=$P(PXKER," * ",2)
  1.  .I PXKER="" Q
  1.  .S (PX,PXFG)=0
  1.  .F  S PX=$O(@PXKVRTN@("AD",PXKVST,PX)) Q:PX=""  D  Q:PXFG=1
  1.  ..S PXJJJ=0
  1.  ..F PXJ=1:1:$L(PXKER,",") S PXJJ=$P(PXKER,",",PXJ) D
  1.  ...I $P($G(@PXKVRTN@(PX,$P(PXJJ,"+",1))),"^",$P(PXJJ,"+",2))=$G(PXKAV($P(PXJJ,"+",1),$P(PXJJ,"+",2))),PX'=PXKPIEN S PXJJJ=PXJJJ+1
  1.  ..I $L(PXKER,",")=PXJJJ S PXFG=1
  1.  ;PXKHLR Is not killed because it is a flag coming from another routine
  1.  Q
  1.  ;
  1. CPTMOD(VCPTIEN,MODIEN) ;
  1.  N IND,VCPTE
  1.  S IND=$O(^AUPNVCPT(VCPTIEN,1,"B",MODIEN,""))
  1.  I IND="" S IND=1
  1.  S VCPTE="^AUPNVCPT("_VCPTIEN_",1,"_IND_",0)"
  1.  Q VCPTE
  1.  ;
  1. ER ;--PXKERROR MAKING IF NOT POPULATED CORRECTLY
  1.  N PXKRT,PXKMOD,PXKSTR
  1.  S PXKMOD=PXKSEQ#1 I $G(PXKMOD) Q
  1.  S PXKN=""
  1.  F  S PXKN=$O(PXKAV(PXKN)) Q:PXKN=""  D
  1.  . I PXKCAT="IMM",PXKN?1(1"2",1"3",1"11") D ER^PXKIMM Q
  1.  . S PXKP=""
  1.  . F  S PXKP=$O(PXKAV(PXKN,PXKP)) Q:PXKP=""  D
  1.  .. S PXKRRT=$P($T(GLOBAL^@PXKRTN),";;",2)_"("_DA_","
  1.  .. I PXKN=1,PXKCAT="CPT" S PXKRRT=$$CPTMOD(PXKPIEN,PXKAV(PXKN,PXKP))
  1.  .. E  S PXKRRT=PXKRRT_PXKN_")"
  1.  .. I PXKAV(PXKN,PXKP)'=$P($G(@PXKRRT),"^",$S(PXKN=1:1,1:PXKP)) D
  1.  ... Q:PXKAV(PXKN,PXKP)["@"
  1.  ... S PXKNOD=PXKN,PXKPCE=PXKP
  1.  ... I PXKNOD=1,PXKCAT="CPT" S PXKPCE=1
  1.  ... D EN2^@PXKRTN
  1.  ... S PXKFLD=$P(PXKFD,"/",1)
  1.  ... S:PXKFLD["*" PXKFLD=$P(PXKFLD," * ",2)
  1.  ... Q:PXKFLD=1101
  1.  ... S PXKSTR="Not Stored = "_PXKAV(PXKN,PXKP)
  1.  ... I $G(PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD))]"" D
  1.  .... S PXKSTR=PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)_","_PXKAV(PXKN,PXKP)
  1.  ... S PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)=PXKSTR
  1.  Q
  1.  ;