- AUPNVDXQ ; IHS/CMI/LAB - SETS "AQ" XREF FOR V DIAGNOSTIC PROCEDURE 24-MAY-1993 ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;MODIFIED FOR PATCH 2 TO SUPPORT AQ CROSS REFERENCES OHPRD/JCM 010195
- AQKILL1 ; ENTRY POINT FROM V DX PROCEDURE DD .01 FIELD TO KILL "AQ" XREF
- N AUPNKKK S AUPNKKK=""
- AQ1 ; ENTRY POINT FROM V DX PROCEDURE DD .01 FIELD TO SET "AQ" XREF
- I X="" Q
- I DUZ("AG")="V",'$P($G(^AUPNVDXP(DA,0)),U,7) Q ;IHS/OHPRD/JCM 8/8/94
- N A,B,C,%,E,F S (A,F)=X
- K:$D(AUPNKKK) ^AUPNVDXP("AQ",(X_";"),DA) ;IHS/OHPRD/JCM 8/8/94
- S X=$P($G(^AUPNVDXP(DA,0)),U,4) I X="" S X=F S:'$D(AUPNKKK) ^AUPNVDXP("AQ",(X_";"),DA)="" Q ;IHS/OHPRD/JCM 8/8/94
- D AQEN S X=F
- Q
- ;
- AQKILL ; ENTRY POINT TO KILL V DX PROCEDURE "AQ" XREF FROM .04 FIELD
- N AUPNKKK S AUPNKKK=""
- AQ ; ENTRY POINT TO SET V DX PROCEDURE "AQ" XREF FROM .04 FIELD
- I X="" Q
- I DUZ("AG")="V",'$P($G(^AUPNVDXP(DA,0)),U,7) Q ;IHS/OHPRD/JCM 8/8/94
- N A,B,C,%,E
- S %=$D(^AUPNVDXP(DA,0)) Q:'% S %=^(0)
- S A=+% I 'A Q
- K:'$D(AUPNKKK) ^AUPNVDXP("AQ",$P(^AUPNVDXP(DA,0),U)_";",DA) ;IHS/OHPRD/JCM 8/8/94
- S:$D(AUPNKKK) ^AUPNVDXP("AQ",$P(^AUPNVDXP(DA,0),U)_";",DA)="" ;IHS/OHPRD/JCM 8/8/94
- AQEN S B=$G(AUPNDXTP) I B="" Q
- I B="S"!(B="G")!(B="L") 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(AUPNKKK) K ^AUPNVDXP("AQ",%,DA) Q
- S ^AUPNVDXP("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
- ;
- STUFF ; SETS V DX PROCEDURE "AQ" XREF WITHOUT CALLING FILEMAN
- K ^AUPNVDXP("AQ")
- F DA=0:0 S DA=$O(^AUPNVDXP(DA)) Q:'DA S X=$G(^(DA,0)),AUPNDXR=+X,X=$P(X,U,4) I X'="",AUPNDXR S AUPNDXTP=$P($G(^AUTTDXPR(AUPNDXR,0)),U,2) I AUPNDXTP'="" D AQ W *13,DA
- K AUPNDXTP,AUPNVDXR
- Q
- ;
- AUPNVDXQ ; IHS/CMI/LAB - SETS "AQ" XREF FOR V DIAGNOSTIC PROCEDURE 24-MAY-1993 ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;MODIFIED FOR PATCH 2 TO SUPPORT AQ CROSS REFERENCES OHPRD/JCM 010195
- AQKILL1 ; ENTRY POINT FROM V DX PROCEDURE DD .01 FIELD TO KILL "AQ" XREF
- +1 NEW AUPNKKK
- SET AUPNKKK=""
- AQ1 ; ENTRY POINT FROM V DX PROCEDURE DD .01 FIELD TO SET "AQ" XREF
- +1 IF X=""
- QUIT
- +2 ;IHS/OHPRD/JCM 8/8/94
- IF DUZ("AG")="V"
- IF '$PIECE($GET(^AUPNVDXP(DA,0)),U,7)
- QUIT
- +3 NEW A,B,C,%,E,F
- SET (A,F)=X
- +4 ;IHS/OHPRD/JCM 8/8/94
- IF $DATA(AUPNKKK)
- KILL ^AUPNVDXP("AQ",(X_";"),DA)
- +5 ;IHS/OHPRD/JCM 8/8/94
- SET X=$PIECE($GET(^AUPNVDXP(DA,0)),U,4)
- IF X=""
- SET X=F
- IF '$DATA(AUPNKKK)
- SET ^AUPNVDXP("AQ",(X_";"),DA)=""
- QUIT
- +6 DO AQEN
- SET X=F
- +7 QUIT
- +8 ;
- AQKILL ; ENTRY POINT TO KILL V DX PROCEDURE "AQ" XREF FROM .04 FIELD
- +1 NEW AUPNKKK
- SET AUPNKKK=""
- AQ ; ENTRY POINT TO SET V DX PROCEDURE "AQ" XREF FROM .04 FIELD
- +1 IF X=""
- QUIT
- +2 ;IHS/OHPRD/JCM 8/8/94
- IF DUZ("AG")="V"
- IF '$PIECE($GET(^AUPNVDXP(DA,0)),U,7)
- QUIT
- +3 NEW A,B,C,%,E
- +4 SET %=$DATA(^AUPNVDXP(DA,0))
- IF '%
- QUIT
- SET %=^(0)
- +5 SET A=+%
- IF 'A
- QUIT
- +6 ;IHS/OHPRD/JCM 8/8/94
- IF '$DATA(AUPNKKK)
- KILL ^AUPNVDXP("AQ",$PIECE(^AUPNVDXP(DA,0),U)_";",DA)
- +7 ;IHS/OHPRD/JCM 8/8/94
- IF $DATA(AUPNKKK)
- SET ^AUPNVDXP("AQ",$PIECE(^AUPNVDXP(DA,0),U)_";",DA)=""
- AQEN SET B=$GET(AUPNDXTP)
- IF B=""
- QUIT
- +1 IF B="S"!(B="G")!(B="L")
- 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(AUPNKKK)
- KILL ^AUPNVDXP("AQ",%,DA)
- QUIT
- +2 SET ^AUPNVDXP("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 ;
- STUFF ; SETS V DX PROCEDURE "AQ" XREF WITHOUT CALLING FILEMAN
- +1 KILL ^AUPNVDXP("AQ")
- +2 FOR DA=0:0
- SET DA=$ORDER(^AUPNVDXP(DA))
- IF 'DA
- QUIT
- SET X=$GET(^(DA,0))
- SET AUPNDXR=+X
- SET X=$PIECE(X,U,4)
- IF X'=""
- IF AUPNDXR
- SET AUPNDXTP=$PIECE($GET(^AUTTDXPR(AUPNDXR,0)),U,2)
- IF AUPNDXTP'=""
- DO AQ
- WRITE *13,DA
- +3 KILL AUPNDXTP,AUPNVDXR
- +4 QUIT
- +5 ;
