- APCDSKL1 ; IHS/CMI/LAB - DISPLAY SKIN TESTS ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;
- A0 S APCDSKLN="" F APCDSKLJ=1:1 S APCDSKLN=$O(^AUPNVSK("AC",APCDPAT,APCDSKLN)) Q:APCDSKLN="" I $D(^AUPNVSK(APCDSKLN,0)) S APCDSKLX=^(0) D SB1
- XA0 S APCDSKLD="",APCDSKLC=0
- A1 S APCDSKLD=$O(APCDSKLA(APCDSKLD)) G C1:APCDSKLD="" D DAT
- A2 S APCDSKLN=""
- A3 S APCDSKLN=$O(APCDSKLA(APCDSKLD,APCDSKLN)) I APCDSKLN="" K APCDSKLA(APCDSKLD) G A1
- S APCDSKLI=$P(APCDSKLA(APCDSKLD,APCDSKLN),"^"),APCDSKLS=$P(APCDSKLA(APCDSKLD,APCDSKLN),"^",2),APCDSKLT=$P(APCDSKLA(APCDSKLD,APCDSKLN),"^",3),APCDSKLR=$P(APCDSKLA(APCDSKLD,APCDSKLN),"^",4)
- A4 I APCDSKLI,$D(^AUTTSK(APCDSKLI,0)) S %I=$P(^(0),"^") S APCDSKLI=%I_" "_APCDSKLI
- W !,$J(APCDSKLC,2)
- W ?3,$J(APCDSKLW,12),?18,$J(APCDSKLI,12),?35,APCDSKLT,?52,APCDSKLS I APCDSKLR D DAR W ?61,APCDSKLW S APCDSKLW=""
- G A3
- C1 W:$Y<22 ! W !,"Press 'ENTER' To Continue: " D SBRS
- C2 I '$D(DFOUT) D KIL Q
- END ;
- KIL K APCDSKLA,APCDSKLT,APCDSKLW,APCDSKLX,APCDSKLD,APCDSKLN,APCDSKLR,APCDSKLI,Y,APCDSKLM Q
- SB1 S APCDSKLD=0,APCDSKLI=$P(APCDSKLX,"^"),APCDSKLV=$P(APCDSKLX,"^",3),APCDSKLS=$P(APCDSKLX,"^",4),APCDSKLL=$P(APCDSKLX,"^",5),APCDSKLR=$P(APCDSKLX,"^",6)
- I APCDSKLV,$D(^AUPNVSIT(APCDSKLV,0)) S APCDSKLD=+$P(^(0),".")
- S APCDSKLA(APCDSKLD,APCDSKLN)=APCDSKLI_"^"_APCDSKLS_"^"_APCDSKLL_"^"_APCDSKLR Q
- DAR ;
- S APCDSKLY=$E(APCDSKLR,1,3)+1700,APCDSKLM=$P(" ^Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",$E(APCDSKLR,4,5)+1),APCDSKLW=+$E(APCDSKLR,6,7) S:'APCDSKLW APCDSKLW=""
- S:APCDSKLW APCDSKLW=$S(APCDSKLW<10:" ",1:"")_APCDSKLW S:APCDSKLM]"" APCDSKLW=APCDSKLM_$S(APCDSKLW]"":" ",1:"")_APCDSKLW_" " S APCDSKLW=APCDSKLW_APCDSKLY Q
- REA ;
- DAT I 'APCDSKLD S APCDSKLW="Not Listed" Q
- S APCDSKLY=$E(APCDSKLD,1,3)+1700,APCDSKLM=$P(" ^Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",$E(APCDSKLD,4,5)+1),APCDSKLW=+$E(APCDSKLD,6,7) S:'APCDSKLW APCDSKLW=""
- S:APCDSKLW APCDSKLW=$S(APCDSKLW<10:" ",1:"")_APCDSKLW S:APCDSKLM]"" APCDSKLW=APCDSKLM_$S(APCDSKLW]"":" ",1:"")_APCDSKLW_" " S APCDSKLW=APCDSKLW_APCDSKLY
- Q
- SBRS K DFOUT,DTOUT,DUOUT,DQOUT
- R Y:$S($D(DTIME):DTIME,1:120) I '$T W $C(7) R Y:5 G SBRS:Y="." I '$T S (DTOUT,DFOUT)="" Q
- I $D(USFO),USFO=Y W:$D(IOF) @IOF S (DFOUT,Y)="" Q
- S:Y="^" (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
- Q
- APCDSKL1 ; IHS/CMI/LAB - DISPLAY SKIN TESTS ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;
- A0 SET APCDSKLN=""
- FOR APCDSKLJ=1:1
- SET APCDSKLN=$ORDER(^AUPNVSK("AC",APCDPAT,APCDSKLN))
- IF APCDSKLN=""
- QUIT
- IF $DATA(^AUPNVSK(APCDSKLN,0))
- SET APCDSKLX=^(0)
- DO SB1
- XA0 SET APCDSKLD=""
- SET APCDSKLC=0
- A1 SET APCDSKLD=$ORDER(APCDSKLA(APCDSKLD))
- IF APCDSKLD=""
- GOTO C1
- DO DAT
- A2 SET APCDSKLN=""
- A3 SET APCDSKLN=$ORDER(APCDSKLA(APCDSKLD,APCDSKLN))
- IF APCDSKLN=""
- KILL APCDSKLA(APCDSKLD)
- GOTO A1
- +1 SET APCDSKLI=$PIECE(APCDSKLA(APCDSKLD,APCDSKLN),"^")
- SET APCDSKLS=$PIECE(APCDSKLA(APCDSKLD,APCDSKLN),"^",2)
- SET APCDSKLT=$PIECE(APCDSKLA(APCDSKLD,APCDSKLN),"^",3)
- SET APCDSKLR=$PIECE(APCDSKLA(APCDSKLD,APCDSKLN),"^",4)
- A4 IF APCDSKLI
- IF $DATA(^AUTTSK(APCDSKLI,0))
- SET %I=$PIECE(^(0),"^")
- SET APCDSKLI=%I_" "_APCDSKLI
- +1 WRITE !,$JUSTIFY(APCDSKLC,2)
- +2 WRITE ?3,$JUSTIFY(APCDSKLW,12),?18,$JUSTIFY(APCDSKLI,12),?35,APCDSKLT,?52,APCDSKLS
- IF APCDSKLR
- DO DAR
- WRITE ?61,APCDSKLW
- SET APCDSKLW=""
- +3 GOTO A3
- C1 IF $Y<22
- WRITE !
- WRITE !,"Press 'ENTER' To Continue: "
- DO SBRS
- C2 IF '$DATA(DFOUT)
- DO KIL
- QUIT
- END ;
- KIL KILL APCDSKLA,APCDSKLT,APCDSKLW,APCDSKLX,APCDSKLD,APCDSKLN,APCDSKLR,APCDSKLI,Y,APCDSKLM
- QUIT
- SB1 SET APCDSKLD=0
- SET APCDSKLI=$PIECE(APCDSKLX,"^")
- SET APCDSKLV=$PIECE(APCDSKLX,"^",3)
- SET APCDSKLS=$PIECE(APCDSKLX,"^",4)
- SET APCDSKLL=$PIECE(APCDSKLX,"^",5)
- SET APCDSKLR=$PIECE(APCDSKLX,"^",6)
- +1 IF APCDSKLV
- IF $DATA(^AUPNVSIT(APCDSKLV,0))
- SET APCDSKLD=+$PIECE(^(0),".")
- +2 SET APCDSKLA(APCDSKLD,APCDSKLN)=APCDSKLI_"^"_APCDSKLS_"^"_APCDSKLL_"^"_APCDSKLR
- QUIT
- DAR ;
- +1 SET APCDSKLY=$EXTRACT(APCDSKLR,1,3)+1700
- SET APCDSKLM=$PIECE(" ^Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",$EXTRACT(APCDSKLR,4,5)+1)
- SET APCDSKLW=+$EXTRACT(APCDSKLR,6,7)
- IF 'APCDSKLW
- SET APCDSKLW=""
- +2 IF APCDSKLW
- SET APCDSKLW=$SELECT(APCDSKLW<10:" ",1:"")_APCDSKLW
- IF APCDSKLM]""
- SET APCDSKLW=APCDSKLM_$SELECT(APCDSKLW]"":" ",1:"")_APCDSKLW_" "
- SET APCDSKLW=APCDSKLW_APCDSKLY
- QUIT
- REA ;
- DAT IF 'APCDSKLD
- SET APCDSKLW="Not Listed"
- QUIT
- +1 SET APCDSKLY=$EXTRACT(APCDSKLD,1,3)+1700
- SET APCDSKLM=$PIECE(" ^Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",$EXTRACT(APCDSKLD,4,5)+1)
- SET APCDSKLW=+$EXTRACT(APCDSKLD,6,7)
- IF 'APCDSKLW
- SET APCDSKLW=""
- +2 IF APCDSKLW
- SET APCDSKLW=$SELECT(APCDSKLW<10:" ",1:"")_APCDSKLW
- IF APCDSKLM]""
- SET APCDSKLW=APCDSKLM_$SELECT(APCDSKLW]"":" ",1:"")_APCDSKLW_" "
- SET APCDSKLW=APCDSKLW_APCDSKLY
- +3 QUIT
- SBRS KILL DFOUT,DTOUT,DUOUT,DQOUT
- +1 READ Y:$SELECT($DATA(DTIME):DTIME,1:120)
- IF '$TEST
- WRITE $CHAR(7)
- READ Y:5
- IF Y="."
- GOTO SBRS
- IF '$TEST
- SET (DTOUT,DFOUT)=""
- QUIT
- +2 IF $DATA(USFO)
- IF USFO=Y
- IF $DATA(IOF)
- WRITE @IOF
- SET (DFOUT,Y)=""
- QUIT
- +3 IF Y="^"
- SET (DUOUT,Y)=""
- IF Y?1"?".E!(Y["^")
- SET (DQOUT,Y)=""
- +4 QUIT
