PXKIMM ;BP/LMT - Main Routine for filing immunization multiples ;10/11/2017
;;1.0;PCE PATIENT CARE ENCOUNTER;**210,211**;Aug 12, 1996;Build 454
;
CLEAN(PXKNODE) ; Clean for IMM multiples. Check to see if PXKAV=PXKBV
;
N PXKSAME
;
I $D(PXKAV(PXKNODE)) D
. ;
. S PXKSAME=1
. ;
. I PXKNODE=11 S PXKSAME=$$CMPRWP("PXKBV("_PXKNODE_")","PXKAV("_PXKNODE_")")
. I PXKNODE'=11 S PXKSAME=$$CMPR(,"PXKBV("_PXKNODE_")","PXKAV("_PXKNODE_")")
. ;
. I PXKSAME K PXKAV(PXKNODE)
;
Q
;
DIE ; File data for multiples
;
N PXKSUB,PXKSUBFILE,PXKWP,PXKIENS,PXKFDA,PXKERR
;
I $G(PXKAV(PXKNOD,0))="@" D PURGE(PXKNOD) Q
;
S PXKIENS=PXKPIEN_","
;
I PXKNOD?1(1"2",1"3") D
. ;
. S PXKSUBFILE=$S(PXKNOD=2:9000010.112,1:9000010.113)
. ;
. S PXKSUB=0
. F S PXKSUB=$O(PXKAV(PXKNOD,PXKSUB)) Q:'PXKSUB D
. . I $G(PXKAV(PXKNOD,PXKSUB,1))="" Q
. . S PXKFDA(1,PXKSUBFILE,"+"_PXKSUB_","_PXKIENS,.01)=PXKAV(PXKNOD,PXKSUB,1)
. . I PXKNOD=2,$G(PXKAV(PXKNOD,PXKSUB,2))'="" D
. . . S PXKFDA(1,PXKSUBFILE,"+"_PXKSUB_","_PXKIENS,.02)=PXKAV(PXKNOD,PXKSUB,2)
. ;
. I '$D(PXKFDA(1)) Q
. ;
. ; Purge previous data before filing updates
. I PXKFGED D PURGE(PXKNOD)
. ;
. D UPDATE^DIE("","PXKFDA(1)",,"PXKERR")
;
I PXKNOD=11 D
. ;
. S PXKSUB=0
. F S PXKSUB=$O(PXKAV(PXKNOD,PXKSUB)) Q:'PXKSUB D
. . S PXKWP(PXKSUB)=$G(PXKAV(PXKNOD,PXKSUB,1))
. ;
. I '$D(PXKWP) Q
. ;
. I PXKFGED D PURGE(PXKNOD)
. ;
. D WP^DIE(9000010.11,PXKIENS,1101,"","PXKWP","PXKERR")
;
Q
;
PURGE(PXKNODE) ; Before filing edits for an entry, purge multiples
;
I '$G(PXKPIEN) Q
;
; Delete data in REMARKS Word-processing field
I PXKNODE=11 D Q
. D WP^DIE("9000010.11",PXKPIEN_",","1101",,"@")
;
; Delete data in VIS and OTHER DIAGNOSIS multiple
I PXKNODE?1(1"2",1"3") D
. N DIK,DA
. S DA(1)=PXKPIEN
. S DIK="^AUPNVIMM("_DA(1)_","_PXKNODE_","
. S DA=0 F S DA=$O(^AUPNVIMM(DA(1),PXKNODE,DA)) Q:'DA D ^DIK
;
Q
;
CMPRWP(PXKLIST1,PXKLIST2) ; Compares two word-processing arrays for equivalence.
;
N PXKSAME,PXKCOUNT1,PXKCOUNT2,PXKSUBIEN1,PXKSUBIEN2,PXKX1,PXKX2
;
S PXKSAME=1 ; flag if before and after arrays are equivalent
;
; check # entries
S PXKCOUNT1=0
S PXKCOUNT2=0
S PXKSUBIEN1=0
F S PXKSUBIEN1=$O(@PXKLIST1@(PXKSUBIEN1)) Q:'PXKSUBIEN1 D
. I $D(@PXKLIST1@(PXKSUBIEN1,0))!($D(@PXKLIST1@(PXKSUBIEN1,1))) S PXKCOUNT1=PXKCOUNT1+1
S PXKSUBIEN2=0
F S PXKSUBIEN2=$O(@PXKLIST2@(PXKSUBIEN2)) Q:'PXKSUBIEN2 D
. I $D(@PXKLIST2@(PXKSUBIEN2,0))!($D(@PXKLIST2@(PXKSUBIEN2,1))) S PXKCOUNT2=PXKCOUNT2+1
I PXKCOUNT1'=PXKCOUNT2 S PXKSAME=0 Q PXKSAME
;
; Check word-processing field. Order and content need to match
S PXKSUBIEN1=0
S PXKSUBIEN2=0
F S PXKSUBIEN1=$O(@PXKLIST1@(PXKSUBIEN1)) Q:'PXKSUBIEN1 D
. S PXKSUBIEN2=$O(@PXKLIST2@(PXKSUBIEN2))
. S PXKX1=$S($G(@PXKLIST1@(PXKSUBIEN1,0))'="":$G(@PXKLIST1@(PXKSUBIEN1,0)),1:$G(@PXKLIST1@(PXKSUBIEN1,1)))
. S PXKX2=$S($G(@PXKLIST2@(PXKSUBIEN2,0))'="":$G(@PXKLIST2@(PXKSUBIEN2,0)),1:$G(@PXKLIST2@(PXKSUBIEN2,1)))
. I PXKX1'=PXKX2 S PXKSAME=0
;
Q PXKSAME
;
CMPR(PXKDIFF,PXKLIST1,PXKLIST2) ;
;
; Compares two arrays for equivalence.
; Returns any data that was in PXKLIST1 that was not in PXKLIST2 in PXKDIFF
;
; PXKLIST1 is in same format as PXKAV and PXKBV arrays
; PXKLIST2 can be in the format of PXKAV/PXKBV arrays or can be in global format.
;
N PXKMATCH,PXKSAME,PXKSUBIEN,PXKVAL,PXKVAL1,PXKTMPBV,PXKSUBIENB
;
S PXKSAME=1 ; flag if before and after arrays are equivalent
;
; Check multiple to see if before and after arrays match. Content needs to match, but order doesn't matter
S PXKSUBIEN=0
F S PXKSUBIEN=$O(@PXKLIST1@(PXKSUBIEN)) Q:'PXKSUBIEN D
. S PXKVAL=$$CONCAT($NA(@PXKLIST1@(PXKSUBIEN))) ; returns array as caret ('^') delimited string
. S PXKVAL1=$P(PXKVAL,U,1)
. I PXKVAL1="" S PXKVAL1=" "
. S PXKTMPBV(PXKVAL1,PXKSUBIEN)=PXKVAL
S PXKSUBIEN=0
F S PXKSUBIEN=$O(@PXKLIST2@(PXKSUBIEN)) Q:'PXKSUBIEN D
. S PXKVAL=$S(PXKLIST2["^":$G(@PXKLIST2@(PXKSUBIEN,0)),1:$$CONCAT($NA(@PXKLIST2@(PXKSUBIEN))))
. S PXKVAL1=$P(PXKVAL,U,1)
. I PXKVAL1="" S PXKVAL1=" "
. S PXKSUBIENB=0
. S PXKMATCH=0
. F S PXKSUBIENB=$O(PXKTMPBV(PXKVAL1,PXKSUBIENB)) Q:'PXKSUBIENB!(PXKMATCH) D
. . I PXKVAL=$G(PXKTMPBV(PXKVAL1,PXKSUBIENB)) D
. . . S PXKMATCH=1
. . . K PXKTMPBV(PXKVAL1,PXKSUBIENB)
. I 'PXKMATCH S PXKSAME=0
;
I $D(PXKTMPBV) D
. S PXKSAME=0
. S PXKVAL1="" F S PXKVAL1=$O(PXKTMPBV(PXKVAL1)) Q:PXKVAL1="" D
. . S PXKSUBIEN=0 F S PXKSUBIEN=$O(PXKTMPBV(PXKVAL1,PXKSUBIEN)) Q:'PXKSUBIEN D
. . . S PXKDIFF(PXKSUBIEN)=$G(PXKTMPBV(PXKVAL1,PXKSUBIEN))
;
Q PXKSAME
;
CONCAT(PXKLIST) ; Concatenates array into a caret ('^') delimited string
;
N PXKI,PXKRESULT
;
S PXKRESULT=""
;
S PXKI=0
F S PXKI=$O(@PXKLIST@(PXKI)) Q:'PXKI D
. S $P(PXKRESULT,U,PXKI)=$G(@PXKLIST@(PXKI))
;
Q PXKRESULT
;
ER ; Check if data was filed ok
;
N PXKSAME,PXKDIFF,PXKFLD,PXKNODE,PXKSUB,PXKSTR
;
; Check VIS and OTHER DIAGNOSIS multiple
F PXKNODE=2,3 D
. K PXKDIFF
. S PXKSAME=$$CMPR(.PXKDIFF,"PXKAV("_PXKNODE_")","^AUPNVIMM("_DA_","_PXKNODE_")")
. I 'PXKSAME,$D(PXKDIFF) D
. . S PXKSUB=0 F S PXKSUB=$O(PXKDIFF(PXKSUB)) Q:'PXKSUB D
. . . S PXKSTR="Not Stored = "_$G(PXKDIFF(PXKSUB))
. . . I $G(PXKERROR(PXKCAT,PXKSEQ,DA,PXKNODE,PXKSUB))'="" D
. . . . S PXKSTR=PXKERROR(PXKCAT,PXKSEQ,DA,PXKNODE,PXKSUB)_","_$G(PXKDIFF(PXKSUB))
. . . S PXKERROR(PXKCAT,PXKSEQ,DA,PXKNODE,PXKSUB)=PXKSTR
;
; Check REMARKS word-processing fields
S PXKSAME=$$CMPRWP("PXKAV(11)","^AUPNVIMM("_DA_",11)")
I 'PXKSAME D
. S PXKFLD=1101
. S PXKSTR="Not Stored = REMARKS Word-processing"
. I $G(PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD))]"" D
. . S PXKSTR=PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)_",REMARKS Word-processing"
. S PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)=PXKSTR
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXKIMM 5915 printed Jan 18, 2025@03:30:26 Page 2
PXKIMM ;BP/LMT - Main Routine for filing immunization multiples ;10/11/2017
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**210,211**;Aug 12, 1996;Build 454
+2 ;
CLEAN(PXKNODE) ; Clean for IMM multiples. Check to see if PXKAV=PXKBV
+1 ;
+2 NEW PXKSAME
+3 ;
+4 IF $DATA(PXKAV(PXKNODE))
Begin DoDot:1
+5 ;
+6 SET PXKSAME=1
+7 ;
+8 IF PXKNODE=11
SET PXKSAME=$$CMPRWP("PXKBV("_PXKNODE_")","PXKAV("_PXKNODE_")")
+9 IF PXKNODE'=11
SET PXKSAME=$$CMPR(,"PXKBV("_PXKNODE_")","PXKAV("_PXKNODE_")")
+10 ;
+11 IF PXKSAME
KILL PXKAV(PXKNODE)
End DoDot:1
+12 ;
+13 QUIT
+14 ;
DIE ; File data for multiples
+1 ;
+2 NEW PXKSUB,PXKSUBFILE,PXKWP,PXKIENS,PXKFDA,PXKERR
+3 ;
+4 IF $GET(PXKAV(PXKNOD,0))="@"
DO PURGE(PXKNOD)
QUIT
+5 ;
+6 SET PXKIENS=PXKPIEN_","
+7 ;
+8 IF PXKNOD?1(1"2",1"3")
Begin DoDot:1
+9 ;
+10 SET PXKSUBFILE=$SELECT(PXKNOD=2:9000010.112,1:9000010.113)
+11 ;
+12 SET PXKSUB=0
+13 FOR
SET PXKSUB=$ORDER(PXKAV(PXKNOD,PXKSUB))
if 'PXKSUB
QUIT
Begin DoDot:2
+14 IF $GET(PXKAV(PXKNOD,PXKSUB,1))=""
QUIT
+15 SET PXKFDA(1,PXKSUBFILE,"+"_PXKSUB_","_PXKIENS,.01)=PXKAV(PXKNOD,PXKSUB,1)
+16 IF PXKNOD=2
IF $GET(PXKAV(PXKNOD,PXKSUB,2))'=""
Begin DoDot:3
+17 SET PXKFDA(1,PXKSUBFILE,"+"_PXKSUB_","_PXKIENS,.02)=PXKAV(PXKNOD,PXKSUB,2)
End DoDot:3
End DoDot:2
+18 ;
+19 IF '$DATA(PXKFDA(1))
QUIT
+20 ;
+21 ; Purge previous data before filing updates
+22 IF PXKFGED
DO PURGE(PXKNOD)
+23 ;
+24 DO UPDATE^DIE("","PXKFDA(1)",,"PXKERR")
End DoDot:1
+25 ;
+26 IF PXKNOD=11
Begin DoDot:1
+27 ;
+28 SET PXKSUB=0
+29 FOR
SET PXKSUB=$ORDER(PXKAV(PXKNOD,PXKSUB))
if 'PXKSUB
QUIT
Begin DoDot:2
+30 SET PXKWP(PXKSUB)=$GET(PXKAV(PXKNOD,PXKSUB,1))
End DoDot:2
+31 ;
+32 IF '$DATA(PXKWP)
QUIT
+33 ;
+34 IF PXKFGED
DO PURGE(PXKNOD)
+35 ;
+36 DO WP^DIE(9000010.11,PXKIENS,1101,"","PXKWP","PXKERR")
End DoDot:1
+37 ;
+38 QUIT
+39 ;
PURGE(PXKNODE) ; Before filing edits for an entry, purge multiples
+1 ;
+2 IF '$GET(PXKPIEN)
QUIT
+3 ;
+4 ; Delete data in REMARKS Word-processing field
+5 IF PXKNODE=11
Begin DoDot:1
+6 DO WP^DIE("9000010.11",PXKPIEN_",","1101",,"@")
End DoDot:1
QUIT
+7 ;
+8 ; Delete data in VIS and OTHER DIAGNOSIS multiple
+9 IF PXKNODE?1(1"2",1"3")
Begin DoDot:1
+10 NEW DIK,DA
+11 SET DA(1)=PXKPIEN
+12 SET DIK="^AUPNVIMM("_DA(1)_","_PXKNODE_","
+13 SET DA=0
FOR
SET DA=$ORDER(^AUPNVIMM(DA(1),PXKNODE,DA))
if 'DA
QUIT
DO ^DIK
End DoDot:1
+14 ;
+15 QUIT
+16 ;
CMPRWP(PXKLIST1,PXKLIST2) ; Compares two word-processing arrays for equivalence.
+1 ;
+2 NEW PXKSAME,PXKCOUNT1,PXKCOUNT2,PXKSUBIEN1,PXKSUBIEN2,PXKX1,PXKX2
+3 ;
+4 ; flag if before and after arrays are equivalent
SET PXKSAME=1
+5 ;
+6 ; check # entries
+7 SET PXKCOUNT1=0
+8 SET PXKCOUNT2=0
+9 SET PXKSUBIEN1=0
+10 FOR
SET PXKSUBIEN1=$ORDER(@PXKLIST1@(PXKSUBIEN1))
if 'PXKSUBIEN1
QUIT
Begin DoDot:1
+11 IF $DATA(@PXKLIST1@(PXKSUBIEN1,0))!($DATA(@PXKLIST1@(PXKSUBIEN1,1)))
SET PXKCOUNT1=PXKCOUNT1+1
End DoDot:1
+12 SET PXKSUBIEN2=0
+13 FOR
SET PXKSUBIEN2=$ORDER(@PXKLIST2@(PXKSUBIEN2))
if 'PXKSUBIEN2
QUIT
Begin DoDot:1
+14 IF $DATA(@PXKLIST2@(PXKSUBIEN2,0))!($DATA(@PXKLIST2@(PXKSUBIEN2,1)))
SET PXKCOUNT2=PXKCOUNT2+1
End DoDot:1
+15 IF PXKCOUNT1'=PXKCOUNT2
SET PXKSAME=0
QUIT PXKSAME
+16 ;
+17 ; Check word-processing field. Order and content need to match
+18 SET PXKSUBIEN1=0
+19 SET PXKSUBIEN2=0
+20 FOR
SET PXKSUBIEN1=$ORDER(@PXKLIST1@(PXKSUBIEN1))
if 'PXKSUBIEN1
QUIT
Begin DoDot:1
+21 SET PXKSUBIEN2=$ORDER(@PXKLIST2@(PXKSUBIEN2))
+22 SET PXKX1=$SELECT($GET(@PXKLIST1@(PXKSUBIEN1,0))'="":$GET(@PXKLIST1@(PXKSUBIEN1,0)),1:$GET(@PXKLIST1@(PXKSUBIEN1,1)))
+23 SET PXKX2=$SELECT($GET(@PXKLIST2@(PXKSUBIEN2,0))'="":$GET(@PXKLIST2@(PXKSUBIEN2,0)),1:$GET(@PXKLIST2@(PXKSUBIEN2,1)))
+24 IF PXKX1'=PXKX2
SET PXKSAME=0
End DoDot:1
+25 ;
+26 QUIT PXKSAME
+27 ;
CMPR(PXKDIFF,PXKLIST1,PXKLIST2) ;
+1 ;
+2 ; Compares two arrays for equivalence.
+3 ; Returns any data that was in PXKLIST1 that was not in PXKLIST2 in PXKDIFF
+4 ;
+5 ; PXKLIST1 is in same format as PXKAV and PXKBV arrays
+6 ; PXKLIST2 can be in the format of PXKAV/PXKBV arrays or can be in global format.
+7 ;
+8 NEW PXKMATCH,PXKSAME,PXKSUBIEN,PXKVAL,PXKVAL1,PXKTMPBV,PXKSUBIENB
+9 ;
+10 ; flag if before and after arrays are equivalent
SET PXKSAME=1
+11 ;
+12 ; Check multiple to see if before and after arrays match. Content needs to match, but order doesn't matter
+13 SET PXKSUBIEN=0
+14 FOR
SET PXKSUBIEN=$ORDER(@PXKLIST1@(PXKSUBIEN))
if 'PXKSUBIEN
QUIT
Begin DoDot:1
+15 ; returns array as caret ('^') delimited string
SET PXKVAL=$$CONCAT($NAME(@PXKLIST1@(PXKSUBIEN)))
+16 SET PXKVAL1=$PIECE(PXKVAL,U,1)
+17 IF PXKVAL1=""
SET PXKVAL1=" "
+18 SET PXKTMPBV(PXKVAL1,PXKSUBIEN)=PXKVAL
End DoDot:1
+19 SET PXKSUBIEN=0
+20 FOR
SET PXKSUBIEN=$ORDER(@PXKLIST2@(PXKSUBIEN))
if 'PXKSUBIEN
QUIT
Begin DoDot:1
+21 SET PXKVAL=$SELECT(PXKLIST2["^":$GET(@PXKLIST2@(PXKSUBIEN,0)),1:$$CONCAT($NAME(@PXKLIST2@(PXKSUBIEN))))
+22 SET PXKVAL1=$PIECE(PXKVAL,U,1)
+23 IF PXKVAL1=""
SET PXKVAL1=" "
+24 SET PXKSUBIENB=0
+25 SET PXKMATCH=0
+26 FOR
SET PXKSUBIENB=$ORDER(PXKTMPBV(PXKVAL1,PXKSUBIENB))
if 'PXKSUBIENB!(PXKMATCH)
QUIT
Begin DoDot:2
+27 IF PXKVAL=$GET(PXKTMPBV(PXKVAL1,PXKSUBIENB))
Begin DoDot:3
+28 SET PXKMATCH=1
+29 KILL PXKTMPBV(PXKVAL1,PXKSUBIENB)
End DoDot:3
End DoDot:2
+30 IF 'PXKMATCH
SET PXKSAME=0
End DoDot:1
+31 ;
+32 IF $DATA(PXKTMPBV)
Begin DoDot:1
+33 SET PXKSAME=0
+34 SET PXKVAL1=""
FOR
SET PXKVAL1=$ORDER(PXKTMPBV(PXKVAL1))
if PXKVAL1=""
QUIT
Begin DoDot:2
+35 SET PXKSUBIEN=0
FOR
SET PXKSUBIEN=$ORDER(PXKTMPBV(PXKVAL1,PXKSUBIEN))
if 'PXKSUBIEN
QUIT
Begin DoDot:3
+36 SET PXKDIFF(PXKSUBIEN)=$GET(PXKTMPBV(PXKVAL1,PXKSUBIEN))
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;
+38 QUIT PXKSAME
+39 ;
CONCAT(PXKLIST) ; Concatenates array into a caret ('^') delimited string
+1 ;
+2 NEW PXKI,PXKRESULT
+3 ;
+4 SET PXKRESULT=""
+5 ;
+6 SET PXKI=0
+7 FOR
SET PXKI=$ORDER(@PXKLIST@(PXKI))
if 'PXKI
QUIT
Begin DoDot:1
+8 SET $PIECE(PXKRESULT,U,PXKI)=$GET(@PXKLIST@(PXKI))
End DoDot:1
+9 ;
+10 QUIT PXKRESULT
+11 ;
ER ; Check if data was filed ok
+1 ;
+2 NEW PXKSAME,PXKDIFF,PXKFLD,PXKNODE,PXKSUB,PXKSTR
+3 ;
+4 ; Check VIS and OTHER DIAGNOSIS multiple
+5 FOR PXKNODE=2,3
Begin DoDot:1
+6 KILL PXKDIFF
+7 SET PXKSAME=$$CMPR(.PXKDIFF,"PXKAV("_PXKNODE_")","^AUPNVIMM("_DA_","_PXKNODE_")")
+8 IF 'PXKSAME
IF $DATA(PXKDIFF)
Begin DoDot:2
+9 SET PXKSUB=0
FOR
SET PXKSUB=$ORDER(PXKDIFF(PXKSUB))
if 'PXKSUB
QUIT
Begin DoDot:3
+10 SET PXKSTR="Not Stored = "_$GET(PXKDIFF(PXKSUB))
+11 IF $GET(PXKERROR(PXKCAT,PXKSEQ,DA,PXKNODE,PXKSUB))'=""
Begin DoDot:4
+12 SET PXKSTR=PXKERROR(PXKCAT,PXKSEQ,DA,PXKNODE,PXKSUB)_","_$GET(PXKDIFF(PXKSUB))
End DoDot:4
+13 SET PXKERROR(PXKCAT,PXKSEQ,DA,PXKNODE,PXKSUB)=PXKSTR
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;
+15 ; Check REMARKS word-processing fields
+16 SET PXKSAME=$$CMPRWP("PXKAV(11)","^AUPNVIMM("_DA_",11)")
+17 IF 'PXKSAME
Begin DoDot:1
+18 SET PXKFLD=1101
+19 SET PXKSTR="Not Stored = REMARKS Word-processing"
+20 IF $GET(PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD))]""
Begin DoDot:2
+21 SET PXKSTR=PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)_",REMARKS Word-processing"
End DoDot:2
+22 SET PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)=PXKSTR
End DoDot:1
+23 ;
+24 QUIT
