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