- 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 Feb 18, 2025@23:55:44 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 ;