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

PXKIMM.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. CLEAN(PXKNODE) ; Clean for IMM multiples. Check to see if PXKAV=PXKBV
  1. ;
  1. N PXKSAME
  1. ;
  1. I $D(PXKAV(PXKNODE)) D
  1. . ;
  1. . S PXKSAME=1
  1. . ;
  1. . I PXKNODE=11 S PXKSAME=$$CMPRWP("PXKBV("_PXKNODE_")","PXKAV("_PXKNODE_")")
  1. . I PXKNODE'=11 S PXKSAME=$$CMPR(,"PXKBV("_PXKNODE_")","PXKAV("_PXKNODE_")")
  1. . ;
  1. . I PXKSAME K PXKAV(PXKNODE)
  1. ;
  1. Q
  1. ;
  1. DIE ; File data for multiples
  1. ;
  1. N PXKSUB,PXKSUBFILE,PXKWP,PXKIENS,PXKFDA,PXKERR
  1. ;
  1. I $G(PXKAV(PXKNOD,0))="@" D PURGE(PXKNOD) Q
  1. ;
  1. S PXKIENS=PXKPIEN_","
  1. ;
  1. I PXKNOD?1(1"2",1"3") D
  1. . ;
  1. . S PXKSUBFILE=$S(PXKNOD=2:9000010.112,1:9000010.113)
  1. . ;
  1. . S PXKSUB=0
  1. . F S PXKSUB=$O(PXKAV(PXKNOD,PXKSUB)) Q:'PXKSUB D
  1. . . I $G(PXKAV(PXKNOD,PXKSUB,1))="" Q
  1. . . S PXKFDA(1,PXKSUBFILE,"+"_PXKSUB_","_PXKIENS,.01)=PXKAV(PXKNOD,PXKSUB,1)
  1. . . I PXKNOD=2,$G(PXKAV(PXKNOD,PXKSUB,2))'="" D
  1. . . . S PXKFDA(1,PXKSUBFILE,"+"_PXKSUB_","_PXKIENS,.02)=PXKAV(PXKNOD,PXKSUB,2)
  1. . ;
  1. . I '$D(PXKFDA(1)) Q
  1. . ;
  1. . ; Purge previous data before filing updates
  1. . I PXKFGED D PURGE(PXKNOD)
  1. . ;
  1. . D UPDATE^DIE("","PXKFDA(1)",,"PXKERR")
  1. ;
  1. I PXKNOD=11 D
  1. . ;
  1. . S PXKSUB=0
  1. . F S PXKSUB=$O(PXKAV(PXKNOD,PXKSUB)) Q:'PXKSUB D
  1. . . S PXKWP(PXKSUB)=$G(PXKAV(PXKNOD,PXKSUB,1))
  1. . ;
  1. . I '$D(PXKWP) Q
  1. . ;
  1. . I PXKFGED D PURGE(PXKNOD)
  1. . ;
  1. . D WP^DIE(9000010.11,PXKIENS,1101,"","PXKWP","PXKERR")
  1. ;
  1. Q
  1. ;
  1. PURGE(PXKNODE) ; Before filing edits for an entry, purge multiples
  1. ;
  1. I '$G(PXKPIEN) Q
  1. ;
  1. ; Delete data in REMARKS Word-processing field
  1. I PXKNODE=11 D Q
  1. . D WP^DIE("9000010.11",PXKPIEN_",","1101",,"@")
  1. ;
  1. ; Delete data in VIS and OTHER DIAGNOSIS multiple
  1. I PXKNODE?1(1"2",1"3") D
  1. . N DIK,DA
  1. . S DA(1)=PXKPIEN
  1. . S DIK="^AUPNVIMM("_DA(1)_","_PXKNODE_","
  1. . S DA=0 F S DA=$O(^AUPNVIMM(DA(1),PXKNODE,DA)) Q:'DA D ^DIK
  1. ;
  1. Q
  1. ;
  1. CMPRWP(PXKLIST1,PXKLIST2) ; Compares two word-processing arrays for equivalence.
  1. ;
  1. N PXKSAME,PXKCOUNT1,PXKCOUNT2,PXKSUBIEN1,PXKSUBIEN2,PXKX1,PXKX2
  1. ;
  1. S PXKSAME=1 ; flag if before and after arrays are equivalent
  1. ;
  1. ; check # entries
  1. S PXKCOUNT1=0
  1. S PXKCOUNT2=0
  1. S PXKSUBIEN1=0
  1. F S PXKSUBIEN1=$O(@PXKLIST1@(PXKSUBIEN1)) Q:'PXKSUBIEN1 D
  1. . I $D(@PXKLIST1@(PXKSUBIEN1,0))!($D(@PXKLIST1@(PXKSUBIEN1,1))) S PXKCOUNT1=PXKCOUNT1+1
  1. S PXKSUBIEN2=0
  1. F S PXKSUBIEN2=$O(@PXKLIST2@(PXKSUBIEN2)) Q:'PXKSUBIEN2 D
  1. . I $D(@PXKLIST2@(PXKSUBIEN2,0))!($D(@PXKLIST2@(PXKSUBIEN2,1))) S PXKCOUNT2=PXKCOUNT2+1
  1. I PXKCOUNT1'=PXKCOUNT2 S PXKSAME=0 Q PXKSAME
  1. ;
  1. ; Check word-processing field. Order and content need to match
  1. S PXKSUBIEN1=0
  1. S PXKSUBIEN2=0
  1. F S PXKSUBIEN1=$O(@PXKLIST1@(PXKSUBIEN1)) Q:'PXKSUBIEN1 D
  1. . S PXKSUBIEN2=$O(@PXKLIST2@(PXKSUBIEN2))
  1. . S PXKX1=$S($G(@PXKLIST1@(PXKSUBIEN1,0))'="":$G(@PXKLIST1@(PXKSUBIEN1,0)),1:$G(@PXKLIST1@(PXKSUBIEN1,1)))
  1. . S PXKX2=$S($G(@PXKLIST2@(PXKSUBIEN2,0))'="":$G(@PXKLIST2@(PXKSUBIEN2,0)),1:$G(@PXKLIST2@(PXKSUBIEN2,1)))
  1. . I PXKX1'=PXKX2 S PXKSAME=0
  1. ;
  1. Q PXKSAME
  1. ;
  1. CMPR(PXKDIFF,PXKLIST1,PXKLIST2) ;
  1. ;
  1. ; Compares two arrays for equivalence.
  1. ; Returns any data that was in PXKLIST1 that was not in PXKLIST2 in PXKDIFF
  1. ;
  1. ; PXKLIST1 is in same format as PXKAV and PXKBV arrays
  1. ; PXKLIST2 can be in the format of PXKAV/PXKBV arrays or can be in global format.
  1. ;
  1. N PXKMATCH,PXKSAME,PXKSUBIEN,PXKVAL,PXKVAL1,PXKTMPBV,PXKSUBIENB
  1. ;
  1. S PXKSAME=1 ; flag if before and after arrays are equivalent
  1. ;
  1. ; Check multiple to see if before and after arrays match. Content needs to match, but order doesn't matter
  1. S PXKSUBIEN=0
  1. F S PXKSUBIEN=$O(@PXKLIST1@(PXKSUBIEN)) Q:'PXKSUBIEN D
  1. . S PXKVAL=$$CONCAT($NA(@PXKLIST1@(PXKSUBIEN))) ; returns array as caret ('^') delimited string
  1. . S PXKVAL1=$P(PXKVAL,U,1)
  1. . I PXKVAL1="" S PXKVAL1=" "
  1. . S PXKTMPBV(PXKVAL1,PXKSUBIEN)=PXKVAL
  1. S PXKSUBIEN=0
  1. F S PXKSUBIEN=$O(@PXKLIST2@(PXKSUBIEN)) Q:'PXKSUBIEN D
  1. . S PXKVAL=$S(PXKLIST2["^":$G(@PXKLIST2@(PXKSUBIEN,0)),1:$$CONCAT($NA(@PXKLIST2@(PXKSUBIEN))))
  1. . S PXKVAL1=$P(PXKVAL,U,1)
  1. . I PXKVAL1="" S PXKVAL1=" "
  1. . S PXKSUBIENB=0
  1. . S PXKMATCH=0
  1. . F S PXKSUBIENB=$O(PXKTMPBV(PXKVAL1,PXKSUBIENB)) Q:'PXKSUBIENB!(PXKMATCH) D
  1. . . I PXKVAL=$G(PXKTMPBV(PXKVAL1,PXKSUBIENB)) D
  1. . . . S PXKMATCH=1
  1. . . . K PXKTMPBV(PXKVAL1,PXKSUBIENB)
  1. . I 'PXKMATCH S PXKSAME=0
  1. ;
  1. I $D(PXKTMPBV) D
  1. . S PXKSAME=0
  1. . S PXKVAL1="" F S PXKVAL1=$O(PXKTMPBV(PXKVAL1)) Q:PXKVAL1="" D
  1. . . S PXKSUBIEN=0 F S PXKSUBIEN=$O(PXKTMPBV(PXKVAL1,PXKSUBIEN)) Q:'PXKSUBIEN D
  1. . . . S PXKDIFF(PXKSUBIEN)=$G(PXKTMPBV(PXKVAL1,PXKSUBIEN))
  1. ;
  1. Q PXKSAME
  1. ;
  1. CONCAT(PXKLIST) ; Concatenates array into a caret ('^') delimited string
  1. ;
  1. N PXKI,PXKRESULT
  1. ;
  1. S PXKRESULT=""
  1. ;
  1. S PXKI=0
  1. F S PXKI=$O(@PXKLIST@(PXKI)) Q:'PXKI D
  1. . S $P(PXKRESULT,U,PXKI)=$G(@PXKLIST@(PXKI))
  1. ;
  1. Q PXKRESULT
  1. ;
  1. ER ; Check if data was filed ok
  1. ;
  1. N PXKSAME,PXKDIFF,PXKFLD,PXKNODE,PXKSUB,PXKSTR
  1. ;
  1. ; Check VIS and OTHER DIAGNOSIS multiple
  1. F PXKNODE=2,3 D
  1. . K PXKDIFF
  1. . S PXKSAME=$$CMPR(.PXKDIFF,"PXKAV("_PXKNODE_")","^AUPNVIMM("_DA_","_PXKNODE_")")
  1. . I 'PXKSAME,$D(PXKDIFF) D
  1. . . S PXKSUB=0 F S PXKSUB=$O(PXKDIFF(PXKSUB)) Q:'PXKSUB D
  1. . . . S PXKSTR="Not Stored = "_$G(PXKDIFF(PXKSUB))
  1. . . . I $G(PXKERROR(PXKCAT,PXKSEQ,DA,PXKNODE,PXKSUB))'="" D
  1. . . . . S PXKSTR=PXKERROR(PXKCAT,PXKSEQ,DA,PXKNODE,PXKSUB)_","_$G(PXKDIFF(PXKSUB))
  1. . . . S PXKERROR(PXKCAT,PXKSEQ,DA,PXKNODE,PXKSUB)=PXKSTR
  1. ;
  1. ; Check REMARKS word-processing fields
  1. S PXKSAME=$$CMPRWP("PXKAV(11)","^AUPNVIMM("_DA_",11)")
  1. I 'PXKSAME D
  1. . S PXKFLD=1101
  1. . S PXKSTR="Not Stored = REMARKS Word-processing"
  1. . I $G(PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD))]"" D
  1. . . S PXKSTR=PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)_",REMARKS Word-processing"
  1. . S PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)=PXKSTR
  1. ;
  1. Q