APCP20P7 ; IHS/TUCSON/LAB - Routine to create bulletin ; [ 12/16/03 3:16 PM ]
;;2.0;IHS PCC DATA EXTRACTION;**7**;APR 03, 1998
;;
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
Q
;
PRE ;EP - pre init
;delete all entries from rec file
S APCPX=0 F S APCPX=$O(^APCPREC(APCPX)) Q:APCPX'=+APCPX S DA=APCPX,DIK="^APCPREC(" D ^DIK
;data will be reloaded with kids install
Q
POST ;EP
OPT ;add 2 new options (supplement, report)
D LAB ;build lab taxonomy
NEW X
S X=$$ADD^XPDMENU("APCPMENU","APCP RE-EXPORT DATE RANGE","EDR")
I 'X W "Attempt to new re-export option failed.." H 3
S X=$$DELETE^XPDMENU("APCPMENU","APCP RE-EXPORT MENU")
S X=$$DELETE^XPDMENU("APCP REPORTS MENU","APCP RPT CHA RECORDS")
;reset all visits with 7 or more diagnoses for reexport by setting APCIS
Q ;do not resend per Donnie
;loop thru APCPLOG, if has .24 then loop thru 21 mult
W !,"checking some visits...hold on"
S APCPDT=$O(^AUPNVSIT("APCIS",0))
S APCPLOG=0 F S APCPLOG=$O(^APCPLOG(APCPLOG)) Q:APCPLOG'=+APCPLOG D
.Q:$P(^APCPLOG(APCPLOG,0),U,24)=""
.S APCPV=0 F S APCPV=$O(^APCPLOG(APCPLOG,21,APCPV)) Q:APCPV'=+APCPV D
..Q:'$D(^AUPNVSIT(APCPV,0))
..Q:$P(^AUPNVSIT(APCPV,0),U,11)
..S C=0,P=0 F S P=$O(^AUPNVPOV("AD",APCPV,P)) Q:P'=+P S C=C+1
..I C>6 D
...S X=$P(^AUPNVSIT(APCPV,0),U,2) Q:$D(^AUPNVSIT("APCIS",X,APCPV)) ;already in xref
...S X=$P(^AUPNVSIT(APCPV,0),U,13) Q:$D(^AUPNVSIT("APCIS",X,APCPV)) ;already in xref
...S ^AUPNVSIT("APCIS",APCPDT,APCPV)="" W "."
..Q
.Q
Q
LAB ;
S APCPX="APCP PAP SMEAR TESTS" D PAPLAB1
S APCPX="APCP PSA TESTS TAX" D PSALAB1
Q
PAPLAB1 ;
W !,"Creating ",APCPX," Taxonomy..."
S APCPDA=$O(^ATXLAB("B",APCPX,0))
Q:APCPDA ;taxonomy already exisits
S X=APCPX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING ",APCPX," TAX" Q
S APCPTX=+Y,$P(^ATXLAB(APCPTX,0),U,2)=APCPX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60,^ATXLAB(APCPTX,21,0)="^9002228.02101PA^0^0"
S APCPX=$O(^LAB(60,"B","PAP SMEAR",0))
I APCPX S ^ATXLAB(APCPTX,21,1,0)=APCPX,^ATXLAB(APCPTX,21,"B",APCPX,1)="",$P(^ATXLAB(APCPTX,21,0),U,3)=APCPX,$P(^ATXLAB(APCPTX,21,0),U,4)=1
S DA=APCPTX,DIK="^ATXAX(" D IX1^DIK
Q
;
PSALAB1 ;
W !,"Creating ",APCPX," Taxonomy..."
S APCPDA=$O(^ATXLAB("B",APCPX,0))
Q:APCPDA ;taxonomy already exisits
S X=APCPX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING ",APCPX," TAX" Q
S APCPTX=+Y,$P(^ATXLAB(APCPTX,0),U,2)=APCPX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60,^ATXLAB(APCPTX,21,0)="^9002228.02101PA^0^0"
S APCPX=$O(^LAB(60,"B","PSA",0))
I APCPX S ^ATXLAB(APCPTX,21,1,0)=APCPX,^ATXLAB(APCPTX,21,"B",APCPX,1)="",$P(^ATXLAB(APCPTX,21,0),U,3)=APCPX,$P(^ATXLAB(APCPTX,21,0),U,4)=1
S DA=APCPTX,DIK="^ATXAX(" D IX1^DIK
Q
;
APCP20P7 ; IHS/TUCSON/LAB - Routine to create bulletin ; [ 12/16/03 3:16 PM ]
+1 ;;2.0;IHS PCC DATA EXTRACTION;**7**;APR 03, 1998
+2 ;;
+3 ; The following line prevents the "Disable Options..." and "Move
+4 ; Routines..." questions from being asked during the install.
+5 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+6 QUIT
+7 ;
PRE ;EP - pre init
+1 ;delete all entries from rec file
+2 SET APCPX=0
FOR
SET APCPX=$ORDER(^APCPREC(APCPX))
IF APCPX'=+APCPX
QUIT
SET DA=APCPX
SET DIK="^APCPREC("
DO ^DIK
+3 ;data will be reloaded with kids install
+4 QUIT
POST ;EP
OPT ;add 2 new options (supplement, report)
+1 ;build lab taxonomy
DO LAB
+2 NEW X
+3 SET X=$$ADD^XPDMENU("APCPMENU","APCP RE-EXPORT DATE RANGE","EDR")
+4 IF 'X
WRITE "Attempt to new re-export option failed.."
HANG 3
+5 SET X=$$DELETE^XPDMENU("APCPMENU","APCP RE-EXPORT MENU")
+6 SET X=$$DELETE^XPDMENU("APCP REPORTS MENU","APCP RPT CHA RECORDS")
+7 ;reset all visits with 7 or more diagnoses for reexport by setting APCIS
+8 ;do not resend per Donnie
QUIT
+9 ;loop thru APCPLOG, if has .24 then loop thru 21 mult
+10 WRITE !,"checking some visits...hold on"
+11 SET APCPDT=$ORDER(^AUPNVSIT("APCIS",0))
+12 SET APCPLOG=0
FOR
SET APCPLOG=$ORDER(^APCPLOG(APCPLOG))
IF APCPLOG'=+APCPLOG
QUIT
Begin DoDot:1
+13 IF $PIECE(^APCPLOG(APCPLOG,0),U,24)=""
QUIT
+14 SET APCPV=0
FOR
SET APCPV=$ORDER(^APCPLOG(APCPLOG,21,APCPV))
IF APCPV'=+APCPV
QUIT
Begin DoDot:2
+15 IF '$DATA(^AUPNVSIT(APCPV,0))
QUIT
+16 IF $PIECE(^AUPNVSIT(APCPV,0),U,11)
QUIT
+17 SET C=0
SET P=0
FOR
SET P=$ORDER(^AUPNVPOV("AD",APCPV,P))
IF P'=+P
QUIT
SET C=C+1
+18 IF C>6
Begin DoDot:3
+19 ;already in xref
SET X=$PIECE(^AUPNVSIT(APCPV,0),U,2)
IF $DATA(^AUPNVSIT("APCIS",X,APCPV))
QUIT
+20 ;already in xref
SET X=$PIECE(^AUPNVSIT(APCPV,0),U,13)
IF $DATA(^AUPNVSIT("APCIS",X,APCPV))
QUIT
+21 SET ^AUPNVSIT("APCIS",APCPDT,APCPV)=""
WRITE "."
End DoDot:3
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 QUIT
LAB ;
+1 SET APCPX="APCP PAP SMEAR TESTS"
DO PAPLAB1
+2 SET APCPX="APCP PSA TESTS TAX"
DO PSALAB1
+3 QUIT
PAPLAB1 ;
+1 WRITE !,"Creating ",APCPX," Taxonomy..."
+2 SET APCPDA=$ORDER(^ATXLAB("B",APCPX,0))
+3 ;taxonomy already exisits
IF APCPDA
QUIT
+4 SET X=APCPX
SET DIC="^ATXLAB("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002228
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+5 IF Y=-1
WRITE !!,"ERROR IN CREATING ",APCPX," TAX"
QUIT
+6 SET APCPTX=+Y
SET $PIECE(^ATXLAB(APCPTX,0),U,2)=APCPX
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,6)=DT
SET $PIECE(^(0),U,8)="B"
SET $PIECE(^(0),U,9)=60
SET ^ATXLAB(APCPTX,21,0)="^9002228.02101PA^0^0"
+7 SET APCPX=$ORDER(^LAB(60,"B","PAP SMEAR",0))
+8 IF APCPX
SET ^ATXLAB(APCPTX,21,1,0)=APCPX
SET ^ATXLAB(APCPTX,21,"B",APCPX,1)=""
SET $PIECE(^ATXLAB(APCPTX,21,0),U,3)=APCPX
SET $PIECE(^ATXLAB(APCPTX,21,0),U,4)=1
+9 SET DA=APCPTX
SET DIK="^ATXAX("
DO IX1^DIK
+10 QUIT
+11 ;
PSALAB1 ;
+1 WRITE !,"Creating ",APCPX," Taxonomy..."
+2 SET APCPDA=$ORDER(^ATXLAB("B",APCPX,0))
+3 ;taxonomy already exisits
IF APCPDA
QUIT
+4 SET X=APCPX
SET DIC="^ATXLAB("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002228
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+5 IF Y=-1
WRITE !!,"ERROR IN CREATING ",APCPX," TAX"
QUIT
+6 SET APCPTX=+Y
SET $PIECE(^ATXLAB(APCPTX,0),U,2)=APCPX
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,6)=DT
SET $PIECE(^(0),U,8)="B"
SET $PIECE(^(0),U,9)=60
SET ^ATXLAB(APCPTX,21,0)="^9002228.02101PA^0^0"
+7 SET APCPX=$ORDER(^LAB(60,"B","PSA",0))
+8 IF APCPX
SET ^ATXLAB(APCPTX,21,1,0)=APCPX
SET ^ATXLAB(APCPTX,21,"B",APCPX,1)=""
SET $PIECE(^ATXLAB(APCPTX,21,0),U,3)=APCPX
SET $PIECE(^ATXLAB(APCPTX,21,0),U,4)=1
+9 SET DA=APCPTX
SET DIK="^ATXAX("
DO IX1^DIK
+10 QUIT
+11 ;
