APCPAOTH ; IHS/TUCSON/LAB - extract APC imm/skin/mh data AUGUST 14, 1992 ; [ 12/16/03 8:19 AM ]
;;2.0;IHS PCC DATA EXTRACTION SYSTEM;**1,7**;APR 03, 1998
;IHS/CMI/LAB - 1/5/1999 patch 2 for new Immunization package
;IHS/CMI/LAB - 12-15-03 patch 7, protect against dangling ptr
;to immunization from v immunization (riverside)
;
;
D IMM
I $D(APCPE("ERROR")) S APCPT("FILE")=9000010.11 D EOJ Q
D ST
I $D(APCPE("ERROR")) S APCPT("FILE")=9000010.12 D EOJ Q
D REP
D EOJ
Q
EOJ ;
Q
IMM ;
; get immunizations done
S APCPT("X")=0,APCPT("IMM")=" " F S APCPT("X")=$O(^AUPNVIMM("AD",APCP("V DFN"),APCPT("X"))) Q:APCPT("X")="" S APCPT("Y")=^AUPNVIMM(APCPT("X"),0) D GETIMM
Q
GETIMM ;
;S X=$P(APCPT("Y"),U),X=$P(^AUTTIMM(X,0),U,3) ;IHS/CMI/LAB - patch 2 commented out and replaced with line below
S X=$P(APCPT("Y"),U)
Q:'$D(^AUTTIMM(X,0))
S X=$P(^AUTTIMM(X,0),U,$S($$BI:20,1:3)) ;IHS/CMI/LAB - patch 2 1/5/1999
S (APCPT("IMM 2"),X)=+X,X=$S(X=1:7,X=2:2,X=3:3,X=4:1,X=6:4,X=7:4,X=11:5,X=12:9,X=14:6,X=15:8,X=34:2,1:10)
S APCPT("CHAR")=X
S APCPT("VAL")=$S(APCPT("CHAR")=10:0,1:APCPT("CHAR"))
I APCPT("IMM 2")=17 S APCPT("IMM")=$E(APCPT("IMM"),1,4)_56_$E(APCPT("IMM"),7)_8_$E(APCPT("IMM"),9,10) Q
I APCPT("IMM 2")=18 S APCPT("IMM")=$E(APCPT("IMM"),1,4)_56_$E(APCPT("IMM"),7,10) Q
I APCPT("IMM 2")=8,$P(APCPT("Y"),U,4)="B" S APCPT("IMM")=$E(APCPT("IMM"),1,9)_"A" Q
I APCPT("IMM 2")=8,$P(APCPT("Y"),U,4)'="B" S APCPT("IMM")=$E(APCPT("IMM"),1,8)_"A"_$E(APCPT("IMM"),10) Q
I APCPT("IMM 2")=9,$P(APCPT("Y"),U,4)="B" S APCPT("IMM")=$E(APCPT("IMM"),1,9)_"B" Q
I APCPT("IMM 2")=9,$P(APCPT("Y"),U,4)'="B" S APCPT("IMM")=$E(APCPT("IMM"),1,8)_"B"_$E(APCPT("IMM"),10)
S APCPT("IMM")=$E(APCPT("IMM"),1,(APCPT("CHAR")-1))_APCPT("VAL")_$E(APCPT("IMM"),(APCPT("CHAR")+1),10)
Q
;IHS/CMI/LAB - patch 2 1/5/1999 new subroutine
BI() ;check to see if new imm package is running
Q $S($O(^AUTTIMM(0))<100:0,1:1)
;IHS/CMI/LAB - end new subroutine patch 2
ST ; get skin test reading is PPD and result if TINE
S APCPT("X")=0,APCPT("RES")="" F S APCPT("X")=$O(^AUPNVSK("AD",APCP("V DFN"),APCPT("X"))) Q:APCPT("X")="" D GETRES
Q
;
GETRES ;
S APCPT("Y")=$P(^AUPNVSK(APCPT("X"),0),U) I APCPT("Y")="" S APCPE("ERROR")="E010" Q
S APCPT("Y")=$P(^AUTTSK(APCPT("Y"),0),U,2) I APCPT("Y")="" S APCPE("ERROR")="E010" Q
I APCPT("Y")=20 S APCPT("RES")=$P(^AUPNVSK(APCPT("X"),0),U,4),APCPT("RES")=$S(APCPT("RES")="N":5,APCPT("RES")="P":6,1:"") Q
I APCPT("Y")=21 S APCPT("RES")=$P(^AUPNVSK(APCPT("X"),0),U,5)
I APCPT("RES")="" Q
S APCPT("RES")=$S(APCPT("RES")<5:1,APCPT("RES")>4&(APCPT("RES")<10):2,APCPT("RES")>9&(APCPT("RES")<20):3,APCPT("RES")>19:4,1:"")
;
Q
REP ;
; get reproductive hx info, gravida, lc, method, status
S (APCPT("AG"),APCPT("ALC"),X,APCPT("AS"),APCPT("AFP"))=""
Q:'$D(^AUPNREP(APCPV("PATIENT DFN")))
S APCPT("REP")=^AUPNREP(APCPV("PATIENT DFN"),0)
I $P(APCPT("REP"),U,3)'=$P(APCPV("V DATE"),".") G METH
I $E($P(APCPT("REP"),U,2))'="G" G LC
S APCPT("AG")=+($P($P(APCPT("REP"),U,2),"G",2)) S:$L(APCPT("AG"))=1 APCPT("AG")="0"_APCPT("AG")
LC ;
S APCPT("ALC")=+($P($P(APCPT("REP"),U,2),"LC",2)) S:$L(APCPT("ALC"))=1 APCPT("ALC")="0"_APCPT("ALC")
METH ;
I $P(APCPT("REP"),U,8)'=$P(APCPV("V DATE"),".") Q
S X=$P(APCPT("REP"),U,6) Q:X=""
S APCPT("AFP")=$S(X=0:4,X=3:6,X=5:4,X=6:3,1:X)
Q
APCPAOTH ; IHS/TUCSON/LAB - extract APC imm/skin/mh data AUGUST 14, 1992 ; [ 12/16/03 8:19 AM ]
+1 ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;**1,7**;APR 03, 1998
+2 ;IHS/CMI/LAB - 1/5/1999 patch 2 for new Immunization package
+3 ;IHS/CMI/LAB - 12-15-03 patch 7, protect against dangling ptr
+4 ;to immunization from v immunization (riverside)
+5 ;
+6 ;
+7 DO IMM
+8 IF $DATA(APCPE("ERROR"))
SET APCPT("FILE")=9000010.11
DO EOJ
QUIT
+9 DO ST
+10 IF $DATA(APCPE("ERROR"))
SET APCPT("FILE")=9000010.12
DO EOJ
QUIT
+11 DO REP
+12 DO EOJ
+13 QUIT
EOJ ;
+1 QUIT
IMM ;
+1 ; get immunizations done
+2 SET APCPT("X")=0
SET APCPT("IMM")=" "
FOR
SET APCPT("X")=$ORDER(^AUPNVIMM("AD",APCP("V DFN"),APCPT("X")))
IF APCPT("X")=""
QUIT
SET APCPT("Y")=^AUPNVIMM(APCPT("X"),0)
DO GETIMM
+3 QUIT
GETIMM ;
+1 ;S X=$P(APCPT("Y"),U),X=$P(^AUTTIMM(X,0),U,3) ;IHS/CMI/LAB - patch 2 commented out and replaced with line below
+2 SET X=$PIECE(APCPT("Y"),U)
+3 IF '$DATA(^AUTTIMM(X,0))
QUIT
+4 ;IHS/CMI/LAB - patch 2 1/5/1999
SET X=$PIECE(^AUTTIMM(X,0),U,$SELECT($$BI:20,1:3))
+5 SET (APCPT("IMM 2"),X)=+X
SET X=$SELECT(X=1:7,X=2:2,X=3:3,X=4:1,X=6:4,X=7:4,X=11:5,X=12:9,X=14:6,X=15:8,X=34:2,1:10)
+6 SET APCPT("CHAR")=X
+7 SET APCPT("VAL")=$SELECT(APCPT("CHAR")=10:0,1:APCPT("CHAR"))
+8 IF APCPT("IMM 2")=17
SET APCPT("IMM")=$EXTRACT(APCPT("IMM"),1,4)_56_$EXTRACT(APCPT("IMM"),7)_8_$EXTRACT(APCPT("IMM"),9,10)
QUIT
+9 IF APCPT("IMM 2")=18
SET APCPT("IMM")=$EXTRACT(APCPT("IMM"),1,4)_56_$EXTRACT(APCPT("IMM"),7,10)
QUIT
+10 IF APCPT("IMM 2")=8
IF $PIECE(APCPT("Y"),U,4)="B"
SET APCPT("IMM")=$EXTRACT(APCPT("IMM"),1,9)_"A"
QUIT
+11 IF APCPT("IMM 2")=8
IF $PIECE(APCPT("Y"),U,4)'="B"
SET APCPT("IMM")=$EXTRACT(APCPT("IMM"),1,8)_"A"_$EXTRACT(APCPT("IMM"),10)
QUIT
+12 IF APCPT("IMM 2")=9
IF $PIECE(APCPT("Y"),U,4)="B"
SET APCPT("IMM")=$EXTRACT(APCPT("IMM"),1,9)_"B"
QUIT
+13 IF APCPT("IMM 2")=9
IF $PIECE(APCPT("Y"),U,4)'="B"
SET APCPT("IMM")=$EXTRACT(APCPT("IMM"),1,8)_"B"_$EXTRACT(APCPT("IMM"),10)
+14 SET APCPT("IMM")=$EXTRACT(APCPT("IMM"),1,(APCPT("CHAR")-1))_APCPT("VAL")_$EXTRACT(APCPT("IMM"),(APCPT("CHAR")+1),10)
+15 QUIT
+16 ;IHS/CMI/LAB - patch 2 1/5/1999 new subroutine
BI() ;check to see if new imm package is running
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))<100:0,1:1)
+2 ;IHS/CMI/LAB - end new subroutine patch 2
ST ; get skin test reading is PPD and result if TINE
+1 SET APCPT("X")=0
SET APCPT("RES")=""
FOR
SET APCPT("X")=$ORDER(^AUPNVSK("AD",APCP("V DFN"),APCPT("X")))
IF APCPT("X")=""
QUIT
DO GETRES
+2 QUIT
+3 ;
GETRES ;
+1 SET APCPT("Y")=$PIECE(^AUPNVSK(APCPT("X"),0),U)
IF APCPT("Y")=""
SET APCPE("ERROR")="E010"
QUIT
+2 SET APCPT("Y")=$PIECE(^AUTTSK(APCPT("Y"),0),U,2)
IF APCPT("Y")=""
SET APCPE("ERROR")="E010"
QUIT
+3 IF APCPT("Y")=20
SET APCPT("RES")=$PIECE(^AUPNVSK(APCPT("X"),0),U,4)
SET APCPT("RES")=$SELECT(APCPT("RES")="N":5,APCPT("RES")="P":6,1:"")
QUIT
+4 IF APCPT("Y")=21
SET APCPT("RES")=$PIECE(^AUPNVSK(APCPT("X"),0),U,5)
+5 IF APCPT("RES")=""
QUIT
+6 SET APCPT("RES")=$SELECT(APCPT("RES")<5:1,APCPT("RES")>4&(APCPT("RES")<10):2,APCPT("RES")>9&(APCPT("RES")<20):3,APCPT("RES")>19:4,1:"")
+7 ;
+8 QUIT
REP ;
+1 ; get reproductive hx info, gravida, lc, method, status
+2 SET (APCPT("AG"),APCPT("ALC"),X,APCPT("AS"),APCPT("AFP"))=""
+3 IF '$DATA(^AUPNREP(APCPV("PATIENT DFN")))
QUIT
+4 SET APCPT("REP")=^AUPNREP(APCPV("PATIENT DFN"),0)
+5 IF $PIECE(APCPT("REP"),U,3)'=$PIECE(APCPV("V DATE"),".")
GOTO METH
+6 IF $EXTRACT($PIECE(APCPT("REP"),U,2))'="G"
GOTO LC
+7 SET APCPT("AG")=+($PIECE($PIECE(APCPT("REP"),U,2),"G",2))
IF $LENGTH(APCPT("AG"))=1
SET APCPT("AG")="0"_APCPT("AG")
LC ;
+1 SET APCPT("ALC")=+($PIECE($PIECE(APCPT("REP"),U,2),"LC",2))
IF $LENGTH(APCPT("ALC"))=1
SET APCPT("ALC")="0"_APCPT("ALC")
METH ;
+1 IF $PIECE(APCPT("REP"),U,8)'=$PIECE(APCPV("V DATE"),".")
QUIT
+2 SET X=$PIECE(APCPT("REP"),U,6)
IF X=""
QUIT
+3 SET APCPT("AFP")=$SELECT(X=0:4,X=3:6,X=5:4,X=6:3,1:X)
+4 QUIT
