AUPNCIXL.m

AUPNCIXL ; IHS/CMI/LAB - AQ XREFS ON LAB/MEAS 24-MAY-1993 ;  

 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

 ;; MODIFIED TO SUPPORT Q-MAN 1.3 BY GIS/OHPRD MAY 21,1991

 ;

AQKILL1 ;EP - V LAB

 N AMQQKKK S AMQQKKK=""

AQ1 ; ENTRY POINT FROM V LAB DD

 I $P($G(^AUTTSITE(1,0)),U,19)'="Y" Q

 I X="" Q

 N A,B,C,%,E,F S (A,F)=X

 K:$D(AMQQKKK) ^AUPNVLAB("AQ",(X_";"),DA) ;IHS/OHPRD/JCM 8/3/94

 S X=$P($G(^AUPNVLAB(DA,0)),U,4) I X="" S X=F S:'$D(AMQQKKK) ^AUPNVLAB("AQ",(X_";"),DA)="" Q  ;IHS/OHPRD/JCM 8/3/94

 D AQEN S X=F

 Q

 ;

AQKILL ; EP

 N AMQQKKK S AMQQKKK=""

AQ ; EP - VLAB

 I $P($G(^AUTTSITE(1,0)),U,19)'="Y" Q

 N A,B,C,%,E

 I X="" Q

 S %=$D(^AUPNVLAB(DA,0)) Q:'%  S %=^(0)

 S A=+% I 'A Q

 K:'$D(AMQQKKK) ^AUPNVLAB("AQ",$P(^AUPNVLAB(DA,0),U)_";",DA) ;IHS/OHPRD/JCM 8/3/94

 S:$D(AMQQKKK) ^AUPNVLAB("AQ",$P(^AUPNVLAB(DA,0),U)_";",DA)="" ;IHS/OHPRD/JCM 8/3/94

AQEN S B=$O(^AMQQ(5,"AQ",A,"")) I B="" Q

 I B="S" S C=X D AQSET Q

 I "><"[$E(X) S X=$E(X,2,99)

 D @("AQ"_B)

 Q

 ;

AQZ I "nN"[$E(X) S C=0 D AQSET Q

 I "tT"[$E(X) S C=1 D AQSET Q

 I $E(X,1,2)?1N1"+" S C=+X I X,X<5 S C=X+1 D AQSET Q

 Q

 ;

AQSET S %=A_";"_C

 I $D(AMQQKKK) K ^AUPNVLAB("AQ",%,DA) Q

 S ^AUPNVLAB("AQ",%,DA)=""

 Q

 ;

AQT I "nN"[$E(X) S C="000000000" D AQSET Q

 I "pP"[$E(X) S C="000000001" D AQSET Q

 I $E(X,1,2)="1:" S C=+$P(X,":",2) I C S E="000000000" D AQPAD,AQSET Q

 Q

 ;

AQN S C=+X I C S E="0000" D AQPAD,AQSET

 Q

 ;

AQQ S C=("Nn"'[$E(X))

 D AQSET

 Q

 ;

AQPAD S %=$P(C,"."),%=$E(E,1,$L(E)-$L(%))_%

 I $P(C,".",2) S %=%_"."

 S C=%_$P(C,".",2)

 Q

 ;

LSTUFF ; SETS V LAB "AQ" XREF

 K ^AUPNVLAB("AQ")

 F DA=0:0 S DA=$O(^AUPNVLAB(DA)) Q:'DA  S X=$G(^(DA,0)),X=$P(X,U,4) I X'="" D AQ W *13,DA

 Q

 ;

AQEKILL1 ; EP - V EXAM .01

 N AMQQKKK S AMQQKKK=""

AQE1 ; ENTRY POINT TO SET V EXAM "AQ" XREF FROM .01 FIELD

 I $P($G(^AUTTSITE(1,0)),U,19)'="Y" Q

 I X="" Q

 N A,B,C,%,E S A=X

 K:$D(AMQQKKK) ^AUPNVXAM("AQ",(X_";"),DA) ;IHS/OHPRD/JCM 8/3/94

 N X S X=$P($G(^AUPNVXAM(DA,0)),U,4) I X="" S X=A S:'$D(AMQQKKK) ^AUPNVXAM("AQ",(X_";"),DA)="" Q  ;IHS/OHPRD/JCM 8/3/94

 D EXEN

 Q

 ;

AQEKILL ; EP - V EXAM AQ

 N AMQQKKK S AMQQKKK=""

AQE ; ENTRY POINT FROM V EXAM DATA DICTIONARY

 I $P($G(^AUTTSITE(1,0)),U,19)'="Y" Q

 I X="" Q

 N A,B,C,%,E

 S A=+$G(^AUPNVXAM(DA,0)) I 'A Q

 K:'$D(AMQQKKK) ^AUPNVXAM("AQ",$P(^AUPNVXAM(DA,0),U)_";",DA) ;IHS/OHPRD/JCM 8/3/94

 S:$D(AMQQKKK) ^AUPNVXAM("AQ",$P(^AUPNVXAM(DA,0),U)_";",DA)="" ;IHS/OHPRD/JCM 8/3/94

EXEN S C=("Nn"'[$E(X))

 S %=A_";"_C

 I $D(AMQQKKK) K ^AUPNVXAM("AQ",%,DA) Q

 S ^AUPNVXAM("AQ",%,DA)=""

 Q

 ;

ESTUFF ; SETS V EXAM XREF

 K ^AUPNVXAM("AQ")

 F DA=0:0 S DA=$O(^AUPNVXAM(DA)) Q:'DA  S X=$G(^(DA,0)),X=$P(X,U,4) D AQE W *13,DA

 Q

 ;

AQSKILL1 ; ENTRY POINT TO KILL V SKIN TEST "AQ" XREF FROM .01 FIELD

 N AMQQKKK S AMQQKKK=""

AQS1 ; ENTRY POINT TO SET V SKIN TEST "AQ" XREF FROM .01 FIELD

 I $P($G(^AUTTSITE(1,0)),U,19)'="Y" Q

 I X="" Q

 N A,B,C,%,E S A=X

 K:$D(AMQQKKK) ^AUPNVSK("AQ",(X_";"),DA) ;IHS/OHPRD/JCM 8/3/94

 N X S X=$P($G(^AUPNVSK(DA,0)),U,5) I X="" S X=A S:'$D(AMQQKKK) ^AUPNVSK("AQ",(X_";"),DA)="" Q  ;IHS/OHPRD/JCM 8/4/94

 ;N X S X=$P(^AUPNVSK(DA,0),U,4) I X="" Q  ;IHS/OHPRD/JCM

 D SKEN

 Q

 ;

AQSKILL ; ENTRY POINT FOR AQ XREF FOR V SKIN TEST FILE

 N AMQQKKK S AMQQKKK=""

AQS ; ENTRY POINT FOR AQ XREF FOR V SKIN TEST FILE

 I $P($G(^AUTTSITE(1,0)),U,19)'="Y" Q

 I X="" Q

 N A,B,C,%,E

 S A=+$G(^AUPNVSK(DA,0)) I 'A Q

 K:'$D(AMQQKKK) ^AUPNVSK("AQ",$P(^AUPNVSK(DA,0),U)_";",DA) ;IHS/OHPRD/JCM 8/3/94

 S:$D(AMQQKKK) ^AUPNVSK("AQ",$P(^AUPNVSK(DA,0),U)_";",DA)="" ;IHS/OHPRD/JCM 8/3/94

SKEN S %=A_";"_(X\1)

 I $D(AMQQKKK) K ^AUPNVSK("AQ",%,DA) Q

 S ^AUPNVSK("AQ",%,DA)=""

 Q

 ;

SSTUFF ; SETS V SKIN TEST AQ XREF WITHOUT CALLING FILEMAN

 K ^AUPNVSK("AQ")

 F DA=0:0 S DA=$O(^AUPNVSK(DA)) Q:'DA  S X=$G(^(DA,0)),X=$P(X,U,5) D AQS W *13,DA

 Q

 ;

AQRKILL1 ; ENTRY POINT TO KILL V RAD "AQ" XREF FROM .01 FIELD

 N AMQQKKK S AMQQKKK=""

AQR1 ; ENTRY POINT TO SET V RAD "AQ" XREF FROM .01 FIELD

 I $P($G(^AUTTSITE(1,0)),U,19)'="Y" Q

 I X="" Q

 N A,% S A=X

 K:$D(AMQQKKK) ^AUPNVRAD("AQ",(X_";"),DA) ;IHS/OHPRD/JCM 8/8/94

 N X S X=$P(^AUPNVRAD(DA,0),U,5) I X="" S X=A S:'$D(AMQQKKK) ^AUPNVRAD("AQ",(X_";"),DA)="" Q  ;IHS/OHPRD/JCM 8/8/94

 D RADEN

 Q

 ;

AQRKILL ; ENTRY POINT FOR AQ XREF FOR V RAD FILE

 N AMQQKKK S AMQQKKK=""

AQR ; ENTRY POINT FROM V RAD ,"AQ" XREF, .05 FIELD

 I $P($G(^AUTTSITE(1,0)),U,19)'="Y" Q

 I X="" Q

 N A,%

 S A=+$G(^AUPNVRAD(DA,0)) I 'A Q

 K:'$D(AMQQKKK) ^AUPNVRAD("AQ",$P(^AUPNVRAD(DA,0),U)_";",DA) ;IHS/OHPRD./JCM 8/8/94

 S:$D(AMQQKKK) ^AUPNVRAD("AQ",$P(^AUPNVRAD(DA,0),U)_";",DA)="" ;IHS/OHPRD/JCM 8/8/94

RADEN S %=A_";"_X

 I $D(AMQQKKK) K ^AUPNVRAD("AQ",%,DA) Q

 S ^AUPNVRAD("AQ",%,DA)=""

 Q

 ;

RSTUFF ; SETS V RAD XREF WITHOUT CALLING FILEMAN

 K ^AUPNVRAD("AQ")

 F DA=0:0 S DA=$O(^AUPNVRAD(DA)) Q:'DA  S X=$G(^(DA,0)),X=$P(X,U,5) D AQR W *13,DA

 Q

 ;

WHBUL ;

 NEW XMSUB,XMDUZ,XMTEXT,XMY,AUPNC

 KILL ^TMP($J,"AUPNDEBUL")

 ;get default case manager

 S X=$P($G(^BWSITE(AUPNSITE,0)),U,2)

 I X="" Q

 S XMY(X)=""

 D WRITEMSG

SUBJECT S XMSUB="* * * IMPORTANT WOMEN'S HEALTH INFORMATION * * *"

SENDER S XMDUZ="PCC - Pap Smear entry auto add to WH"

 S XMTEXT="^TMP($J,""AUPNDEBUL"","

 D ^XMD

 KILL ^TMP($J,"AUPNDEBUL")

 Q

 ;

WRITEMSG ;

 S AUPNC=0

 S X="*********** WOMEN'S HEALTH INFORMATION *************" D SET

 S X="This message is to inform you that a Pap Smear was entered into PCC" D SET

 S X="for Patient "_$P(^DPT(AUPNDFN,0),U)_" (Chart #: "_$$HRN^AUPNPAT(AUPNDFN,AUPNSITE)_").  The date of the" D SET

 S X="Pap Smear was "_$$FMTE^XLFDT(AUPNWHDT)_".  An attempt was made to " D SET

 S X="automatically add this Pap Smear to the Women's Health module." D SET

 S X="This attempt failed because the patient is not on the WH Register." D SET

 S X="Review the information and if appropriate, add this patient to your" D SET

 S X="Register.  This Pap Smear may be manually added to the" D SET

 S X="patient's profile after the patient is added to the Register." D SET

 S X=" " D SET

 Q

 ;;  

SET ;

 S AUPNC=AUPNC+1

 S ^TMP($J,"AUPNDEBUL",AUPNC)=X

 Q

PAP(T) ;EP - called from V LAB AWH xref

 I '$G(T) Q 0

 I $P($G(^LAB(60,T,0)),U)="PAP SMEAR" Q 1

 NEW S

 S S=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))

 I 'S Q 0

 I $D(^ATXLAB(S,21,"B",T)) Q 1

 Q 0

WH(AUPNDFN,AUPNDA,AUPNVST,AUPNSITE) ;EP - called from xref on V LAB .01

 I '$G(AUPNSITE) Q  ;no site

 I $P($G(^APCCCTRL(AUPNSITE,0)),U,9)'=1 Q  ;does not specify to pass them

 ;called to create a WH entry for PAP SMEAR

 NEW AUPNWHDT

 I '$G(AUPNDFN) Q

 I '$G(AUPNVST) Q

 I '$D(^AUPNVSIT(AUPNVST)) Q

 Q:$D(DIGFLINE)  ;in MFI

 I '$D(^DPT(AUPNDFN,0)) Q

 S AUPNWHDT=$P($P(^AUPNVSIT(AUPNVST,0),U),".")

 I '$D(^BWP(AUPNDFN,0)) D EN^XBNEW("WHBUL^AUPNCIXL","AUPNDFN;AUPNDA;AUPNVST;AUPNWHDT;AUPNSITE") Q  ;women is not on WH register

 D EN^XBNEW("WH1^AUPNCIXL","AUPNDFN;AUPNDA;AUPNVST;AUPNWHDT")

 K AUPNDFN,AUPNDA,AUPNVST,AUPNWHDT

 Q

WH1 ;

 ;check to see if pap already there, if not add it.

 ;go through procedures in a date range for this patient, check proc type

 NEW D,X,Y,G,V,T

 S T=$O(^BWPN("B","PAP SMEAR",0))

 I 'T Q

 S (G,V)=0 F  S V=$O(^BWPCD("C",AUPNDFN,V)) Q:V=""!(G)  D

 .Q:'$D(^BWPCD(V,0))

 .I $P(^BWPCD(V,0),U,4)'=T Q

 .I AUPNWHDT'=$P(^BWPCD(V,0),U,12) Q

 .S G=1

 .Q

 I G Q  ;already has pap smear

 ;ADD PAP TO WH PROCEDURE FILE

PROC ;---> Create PAP SMEAR Procedure in BW PROCEDURE File #9002086.1.

 ;---> 1=IEN of Procedure Type in File #9002086.2.

 ;

 ;---> Optional use of DR string.

 S AUPNDR=".02////"_AUPNDFN_";.03////"_$P($G(^AUPNVSIT(AUPNVST,0)),U)_";.04////1"

 S AUPNDR=AUPNDR_";.1////"_$P(^AUPNVSIT(AUPNVST,0),U,6)

 S AUPNDR=AUPNDR_";.12////"_$P($G(AUPNWHDT),".")_";.14////o"

 S AUPNDR=AUPNDR_";.18////"_DUZ_";.19////"_DT

 S AUPNERR=0

 ;

 D NEW2^BWPROC(AUPNDFN,1,AUPNWHDT,AUPNDR,"",.AUPNDADA,.AUPNERR)

 I AUPNERR<0 D  Q

 .S BWERR="Software error: Failed to create PAP in Women's Health."

 ;

 ;---> BWDA=IEN of just created Procedure in BW PROCEDURE File.

 ;---> Following line will call ^APCDALV and ^APCDALVR.

 ;---> Call to APCDALV will look for same date Visit and prompt

 ;---> if time does not match.  (See +53^BWPCC.)

STORE ;---> STORE VISIT AND V FILE IEN'S IN WH PROCEDURE FILE #9002086.1.

 I $G(AUPNDADA) D

 .N DR

 .S DR="5.01////"_AUPNVST_";5.02////"_AUPNDA

 .S DIE="^BWPCD(",DA=AUPNDADA

 .D ^DIE

 .K DIE,DA,DR

 Q

AUPNCIXL  ; IHS/CMI/LAB - AQ XREFS ON LAB/MEAS 24-MAY-1993 ;  

 +1       ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

 +2       ;; MODIFIED TO SUPPORT Q-MAN 1.3 BY GIS/OHPRD MAY 21,1991

 +3       ;

AQKILL1   ;EP - V LAB

 +1        NEW AMQQKKK

           SET AMQQKKK=""

AQ1       ; ENTRY POINT FROM V LAB DD

 +1        IF $PIECE($GET(^AUTTSITE(1,0)),U,19)'="Y"

               QUIT 

 +2        IF X=""

               QUIT 

 +3        NEW A,B,C,%,E,F

           SET (A,F)=X

 +4       ;IHS/OHPRD/JCM 8/3/94

           IF $DATA(AMQQKKK)

               KILL ^AUPNVLAB("AQ",(X_";"),DA)

 +5       ;IHS/OHPRD/JCM 8/3/94

           SET X=$PIECE($GET(^AUPNVLAB(DA,0)),U,4)

           IF X=""

               SET X=F

               IF '$DATA(AMQQKKK)

                   SET ^AUPNVLAB("AQ",(X_";"),DA)=""

               QUIT 

 +6        DO AQEN

           SET X=F

 +7        QUIT 

 +8       ;

AQKILL    ; EP

 +1        NEW AMQQKKK

           SET AMQQKKK=""

AQ        ; EP - VLAB

 +1        IF $PIECE($GET(^AUTTSITE(1,0)),U,19)'="Y"

               QUIT 

 +2        NEW A,B,C,%,E

 +3        IF X=""

               QUIT 

 +4        SET %=$DATA(^AUPNVLAB(DA,0))

           IF '%

               QUIT 

           SET %=^(0)

 +5        SET A=+%

           IF 'A

               QUIT 

 +6       ;IHS/OHPRD/JCM 8/3/94

           IF '$DATA(AMQQKKK)

               KILL ^AUPNVLAB("AQ",$PIECE(^AUPNVLAB(DA,0),U)_";",DA)

 +7       ;IHS/OHPRD/JCM 8/3/94

           IF $DATA(AMQQKKK)

               SET ^AUPNVLAB("AQ",$PIECE(^AUPNVLAB(DA,0),U)_";",DA)=""

AQEN       SET B=$ORDER(^AMQQ(5,"AQ",A,""))

           IF B=""

               QUIT 

 +1        IF B="S"

               SET C=X

               DO AQSET

               QUIT 

 +2        IF "><"[$EXTRACT(X)

               SET X=$EXTRACT(X,2,99)

 +3        DO @("AQ"_B)

 +4        QUIT 

 +5       ;

AQZ        IF "nN"[$EXTRACT(X)

               SET C=0

               DO AQSET

               QUIT 

 +1        IF "tT"[$EXTRACT(X)

               SET C=1

               DO AQSET

               QUIT 

 +2        IF $EXTRACT(X,1,2)?1N1"+"

               SET C=+X

               IF X

                   IF X<5

                       SET C=X+1

                       DO AQSET

                       QUIT 

 +3        QUIT 

 +4       ;

AQSET      SET %=A_";"_C

 +1        IF $DATA(AMQQKKK)

               KILL ^AUPNVLAB("AQ",%,DA)

               QUIT 

 +2        SET ^AUPNVLAB("AQ",%,DA)=""

 +3        QUIT 

 +4       ;

AQT        IF "nN"[$EXTRACT(X)

               SET C="000000000"

               DO AQSET

               QUIT 

 +1        IF "pP"[$EXTRACT(X)

               SET C="000000001"

               DO AQSET

               QUIT 

 +2        IF $EXTRACT(X,1,2)="1:"

               SET C=+$PIECE(X,":",2)

               IF C

                   SET E="000000000"

                   DO AQPAD

                   DO AQSET

                   QUIT 

 +3        QUIT 

 +4       ;

AQN        SET C=+X

           IF C

               SET E="0000"

               DO AQPAD

               DO AQSET

 +1        QUIT 

 +2       ;

AQQ        SET C=("Nn"'[$EXTRACT(X))

 +1        DO AQSET

 +2        QUIT 

 +3       ;

AQPAD      SET %=$PIECE(C,".")

           SET %=$EXTRACT(E,1,$LENGTH(E)-$LENGTH(%))_%

 +1        IF $PIECE(C,".",2)

               SET %=%_"."

 +2        SET C=%_$PIECE(C,".",2)

 +3        QUIT 

 +4       ;

LSTUFF    ; SETS V LAB "AQ" XREF

 +1        KILL ^AUPNVLAB("AQ")

 +2        FOR DA=0:0

               SET DA=$ORDER(^AUPNVLAB(DA))

               IF 'DA

                   QUIT 

               SET X=$GET(^(DA,0))

               SET X=$PIECE(X,U,4)

               IF X'=""

                   DO AQ

                   WRITE *13,DA

 +3        QUIT 

 +4       ;

AQEKILL1  ; EP - V EXAM .01

 +1        NEW AMQQKKK

           SET AMQQKKK=""

AQE1      ; ENTRY POINT TO SET V EXAM "AQ" XREF FROM .01 FIELD

 +1        IF $PIECE($GET(^AUTTSITE(1,0)),U,19)'="Y"

               QUIT 

 +2        IF X=""

               QUIT 

 +3        NEW A,B,C,%,E

           SET A=X

 +4       ;IHS/OHPRD/JCM 8/3/94

           IF $DATA(AMQQKKK)

               KILL ^AUPNVXAM("AQ",(X_";"),DA)

 +5       ;IHS/OHPRD/JCM 8/3/94

           NEW X

           SET X=$PIECE($GET(^AUPNVXAM(DA,0)),U,4)

           IF X=""

               SET X=A

               IF '$DATA(AMQQKKK)

                   SET ^AUPNVXAM("AQ",(X_";"),DA)=""

               QUIT 

 +6        DO EXEN

 +7        QUIT 

 +8       ;

AQEKILL   ; EP - V EXAM AQ

 +1        NEW AMQQKKK

           SET AMQQKKK=""

AQE       ; ENTRY POINT FROM V EXAM DATA DICTIONARY

 +1        IF $PIECE($GET(^AUTTSITE(1,0)),U,19)'="Y"

               QUIT 

 +2        IF X=""

               QUIT 

 +3        NEW A,B,C,%,E

 +4        SET A=+$GET(^AUPNVXAM(DA,0))

           IF 'A

               QUIT 

 +5       ;IHS/OHPRD/JCM 8/3/94

           IF '$DATA(AMQQKKK)

               KILL ^AUPNVXAM("AQ",$PIECE(^AUPNVXAM(DA,0),U)_";",DA)

 +6       ;IHS/OHPRD/JCM 8/3/94

           IF $DATA(AMQQKKK)

               SET ^AUPNVXAM("AQ",$PIECE(^AUPNVXAM(DA,0),U)_";",DA)=""

EXEN       SET C=("Nn"'[$EXTRACT(X))

 +1        SET %=A_";"_C

 +2        IF $DATA(AMQQKKK)

               KILL ^AUPNVXAM("AQ",%,DA)

               QUIT 

 +3        SET ^AUPNVXAM("AQ",%,DA)=""

 +4        QUIT 

 +5       ;

ESTUFF    ; SETS V EXAM XREF

 +1        KILL ^AUPNVXAM("AQ")

 +2        FOR DA=0:0

               SET DA=$ORDER(^AUPNVXAM(DA))

               IF 'DA

                   QUIT 

               SET X=$GET(^(DA,0))

               SET X=$PIECE(X,U,4)

               DO AQE

               WRITE *13,DA

 +3        QUIT 

 +4       ;

AQSKILL1  ; ENTRY POINT TO KILL V SKIN TEST "AQ" XREF FROM .01 FIELD

 +1        NEW AMQQKKK

           SET AMQQKKK=""

AQS1      ; ENTRY POINT TO SET V SKIN TEST "AQ" XREF FROM .01 FIELD

 +1        IF $PIECE($GET(^AUTTSITE(1,0)),U,19)'="Y"

               QUIT 

 +2        IF X=""

               QUIT 

 +3        NEW A,B,C,%,E

           SET A=X

 +4       ;IHS/OHPRD/JCM 8/3/94

           IF $DATA(AMQQKKK)

               KILL ^AUPNVSK("AQ",(X_";"),DA)

 +5       ;IHS/OHPRD/JCM 8/4/94

           NEW X

           SET X=$PIECE($GET(^AUPNVSK(DA,0)),U,5)

           IF X=""

               SET X=A

               IF '$DATA(AMQQKKK)

                   SET ^AUPNVSK("AQ",(X_";"),DA)=""

               QUIT 

 +6       ;N X S X=$P(^AUPNVSK(DA,0),U,4) I X="" Q  ;IHS/OHPRD/JCM

 +7        DO SKEN

 +8        QUIT 

 +9       ;

AQSKILL   ; ENTRY POINT FOR AQ XREF FOR V SKIN TEST FILE

 +1        NEW AMQQKKK

           SET AMQQKKK=""

AQS       ; ENTRY POINT FOR AQ XREF FOR V SKIN TEST FILE

 +1        IF $PIECE($GET(^AUTTSITE(1,0)),U,19)'="Y"

               QUIT 

 +2        IF X=""

               QUIT 

 +3        NEW A,B,C,%,E

 +4        SET A=+$GET(^AUPNVSK(DA,0))

           IF 'A

               QUIT 

 +5       ;IHS/OHPRD/JCM 8/3/94

           IF '$DATA(AMQQKKK)

               KILL ^AUPNVSK("AQ",$PIECE(^AUPNVSK(DA,0),U)_";",DA)

 +6       ;IHS/OHPRD/JCM 8/3/94

           IF $DATA(AMQQKKK)

               SET ^AUPNVSK("AQ",$PIECE(^AUPNVSK(DA,0),U)_";",DA)=""

SKEN       SET %=A_";"_(X\1)

 +1        IF $DATA(AMQQKKK)

               KILL ^AUPNVSK("AQ",%,DA)

               QUIT 

 +2        SET ^AUPNVSK("AQ",%,DA)=""

 +3        QUIT 

 +4       ;

SSTUFF    ; SETS V SKIN TEST AQ XREF WITHOUT CALLING FILEMAN

 +1        KILL ^AUPNVSK("AQ")

 +2        FOR DA=0:0

               SET DA=$ORDER(^AUPNVSK(DA))

               IF 'DA

                   QUIT 

               SET X=$GET(^(DA,0))

               SET X=$PIECE(X,U,5)

               DO AQS

               WRITE *13,DA

 +3        QUIT 

 +4       ;

AQRKILL1  ; ENTRY POINT TO KILL V RAD "AQ" XREF FROM .01 FIELD

 +1        NEW AMQQKKK

           SET AMQQKKK=""

AQR1      ; ENTRY POINT TO SET V RAD "AQ" XREF FROM .01 FIELD

 +1        IF $PIECE($GET(^AUTTSITE(1,0)),U,19)'="Y"

               QUIT 

 +2        IF X=""

               QUIT 

 +3        NEW A,%

           SET A=X

 +4       ;IHS/OHPRD/JCM 8/8/94

           IF $DATA(AMQQKKK)

               KILL ^AUPNVRAD("AQ",(X_";"),DA)

 +5       ;IHS/OHPRD/JCM 8/8/94

           NEW X

           SET X=$PIECE(^AUPNVRAD(DA,0),U,5)

           IF X=""

               SET X=A

               IF '$DATA(AMQQKKK)

                   SET ^AUPNVRAD("AQ",(X_";"),DA)=""

               QUIT 

 +6        DO RADEN

 +7        QUIT 

 +8       ;

AQRKILL   ; ENTRY POINT FOR AQ XREF FOR V RAD FILE

 +1        NEW AMQQKKK

           SET AMQQKKK=""

AQR       ; ENTRY POINT FROM V RAD ,"AQ" XREF, .05 FIELD

 +1        IF $PIECE($GET(^AUTTSITE(1,0)),U,19)'="Y"

               QUIT 

 +2        IF X=""

               QUIT 

 +3        NEW A,%

 +4        SET A=+$GET(^AUPNVRAD(DA,0))

           IF 'A

               QUIT 

 +5       ;IHS/OHPRD./JCM 8/8/94

           IF '$DATA(AMQQKKK)

               KILL ^AUPNVRAD("AQ",$PIECE(^AUPNVRAD(DA,0),U)_";",DA)

 +6       ;IHS/OHPRD/JCM 8/8/94

           IF $DATA(AMQQKKK)

               SET ^AUPNVRAD("AQ",$PIECE(^AUPNVRAD(DA,0),U)_";",DA)=""

RADEN      SET %=A_";"_X

 +1        IF $DATA(AMQQKKK)

               KILL ^AUPNVRAD("AQ",%,DA)

               QUIT 

 +2        SET ^AUPNVRAD("AQ",%,DA)=""

 +3        QUIT 

 +4       ;

RSTUFF    ; SETS V RAD XREF WITHOUT CALLING FILEMAN

 +1        KILL ^AUPNVRAD("AQ")

 +2        FOR DA=0:0

               SET DA=$ORDER(^AUPNVRAD(DA))

               IF 'DA

                   QUIT 

               SET X=$GET(^(DA,0))

               SET X=$PIECE(X,U,5)

               DO AQR

               WRITE *13,DA

 +3        QUIT 

 +4       ;

WHBUL     ;

 +1        NEW XMSUB,XMDUZ,XMTEXT,XMY,AUPNC

 +2        KILL ^TMP($JOB,"AUPNDEBUL")

 +3       ;get default case manager

 +4        SET X=$PIECE($GET(^BWSITE(AUPNSITE,0)),U,2)

 +5        IF X=""

               QUIT 

 +6        SET XMY(X)=""

 +7        DO WRITEMSG

SUBJECT    SET XMSUB="* * * IMPORTANT WOMEN'S HEALTH INFORMATION * * *"

SENDER     SET XMDUZ="PCC - Pap Smear entry auto add to WH"

 +1        SET XMTEXT="^TMP($J,""AUPNDEBUL"","

 +2        DO ^XMD

 +3        KILL ^TMP($JOB,"AUPNDEBUL")

 +4        QUIT 

 +5       ;

WRITEMSG  ;

 +1        SET AUPNC=0

 +2        SET X="*********** WOMEN'S HEALTH INFORMATION *************"

           DO SET

 +3        SET X="This message is to inform you that a Pap Smear was entered into PCC"

           DO SET

 +4        SET X="for Patient "_$PIECE(^DPT(AUPNDFN,0),U)_" (Chart #: "_$$HRN^AUPNPAT(AUPNDFN,AUPNSITE)_").  The date of the"

           DO SET

 +5        SET X="Pap Smear was "_$$FMTE^XLFDT(AUPNWHDT)_".  An attempt was made to "

           DO SET

 +6        SET X="automatically add this Pap Smear to the Women's Health module."

           DO SET

 +7        SET X="This attempt failed because the patient is not on the WH Register."

           DO SET

 +8        SET X="Review the information and if appropriate, add this patient to your"

           DO SET

 +9        SET X="Register.  This Pap Smear may be manually added to the"

           DO SET

 +10       SET X="patient's profile after the patient is added to the Register."

           DO SET

 +11       SET X=" "

           DO SET

 +12       QUIT 

 +13      ;;  

SET       ;

 +1        SET AUPNC=AUPNC+1

 +2        SET ^TMP($JOB,"AUPNDEBUL",AUPNC)=X

 +3        QUIT 

PAP(T)    ;EP - called from V LAB AWH xref

 +1        IF '$GET(T)

               QUIT 0

 +2        IF $PIECE($GET(^LAB(60,T,0)),U)="PAP SMEAR"

               QUIT 1

 +3        NEW S

 +4        SET S=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))

 +5        IF 'S

               QUIT 0

 +6        IF $DATA(^ATXLAB(S,21,"B",T))

               QUIT 1

 +7        QUIT 0

WH(AUPNDFN,AUPNDA,AUPNVST,AUPNSITE) ;EP - called from xref on V LAB .01

 +1       ;no site

           IF '$GET(AUPNSITE)

               QUIT 

 +2       ;does not specify to pass them

           IF $PIECE($GET(^APCCCTRL(AUPNSITE,0)),U,9)'=1

               QUIT 

 +3       ;called to create a WH entry for PAP SMEAR

 +4        NEW AUPNWHDT

 +5        IF '$GET(AUPNDFN)

               QUIT 

 +6        IF '$GET(AUPNVST)

               QUIT 

 +7        IF '$DATA(^AUPNVSIT(AUPNVST))

               QUIT 

 +8       ;in MFI

           IF $DATA(DIGFLINE)

               QUIT 

 +9        IF '$DATA(^DPT(AUPNDFN,0))

               QUIT 

 +10       SET AUPNWHDT=$PIECE($PIECE(^AUPNVSIT(AUPNVST,0),U),".")

 +11      ;women is not on WH register

           IF '$DATA(^BWP(AUPNDFN,0))

               DO EN^XBNEW("WHBUL^AUPNCIXL","AUPNDFN;AUPNDA;AUPNVST;AUPNWHDT;AUPNSITE")

               QUIT 

 +12       DO EN^XBNEW("WH1^AUPNCIXL","AUPNDFN;AUPNDA;AUPNVST;AUPNWHDT")

 +13       KILL AUPNDFN,AUPNDA,AUPNVST,AUPNWHDT

 +14       QUIT 

WH1       ;

 +1       ;check to see if pap already there, if not add it.

 +2       ;go through procedures in a date range for this patient, check proc type

 +3        NEW D,X,Y,G,V,T

 +4        SET T=$ORDER(^BWPN("B","PAP SMEAR",0))

 +5        IF 'T

               QUIT 

 +6        SET (G,V)=0

           FOR 

               SET V=$ORDER(^BWPCD("C",AUPNDFN,V))

               IF V=""!(G)

                   QUIT 

               Begin DoDot:1

 +7                IF '$DATA(^BWPCD(V,0))

                       QUIT 

 +8                IF $PIECE(^BWPCD(V,0),U,4)'=T

                       QUIT 

 +9                IF AUPNWHDT'=$PIECE(^BWPCD(V,0),U,12)

                       QUIT 

 +10               SET G=1

 +11               QUIT 

               End DoDot:1

 +12      ;already has pap smear

           IF G

               QUIT 

 +13      ;ADD PAP TO WH PROCEDURE FILE

PROC      ;---> Create PAP SMEAR Procedure in BW PROCEDURE File #9002086.1.

 +1       ;---> 1=IEN of Procedure Type in File #9002086.2.

 +2       ;

 +3       ;---> Optional use of DR string.

 +4        SET AUPNDR=".02////"_AUPNDFN_";.03////"_$PIECE($GET(^AUPNVSIT(AUPNVST,0)),U)_";.04////1"

 +5        SET AUPNDR=AUPNDR_";.1////"_$PIECE(^AUPNVSIT(AUPNVST,0),U,6)