BSDX41P.m

BSDX41P ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

 ;

RAD ; ******************* RAD TESTS - ALL * 9000010.12 *******

 ; <SETUP>

 Q:'$D(^AUPNVRAD("AA",APCHSPAT))

 K APCHSRRT

 X APCHSBRK

 ; <DISPLAY>

 S APCHST="" F APCHSQ=0:0 S APCHST=$O(^AUPNVRAD("AA",APCHSPAT,APCHST)) Q:APCHST=""  S APCHSTX=$P(^RAMIS(71,APCHST,0),U,1),APCHSTL=$L(APCHSTX) X APCHSCKP Q:$D(APCHSQIT)  D RADBLD

 ; <CLEANUP>

 ;now display RAD refusals

 S APCHST="RADIOLOGY EXAM",APCHSFN=71 D DISPREF^BSDX41F

 K APCHST,APCHSFN

RADX K APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSRDG,APCHSVDF,APCHSDAT,X,Y

 K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE

 Q

RADBLD S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVRAD("AA",APCHSPAT,APCHST,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D RADBLD1

 Q

RADBLD1 ;S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y

 ;X APCHSCKP Q:$D(APCHSQIT)

 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 S BSDXTMP=APCHSDAT

 S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVRAD("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN)) Q:'APCHSDFN  D

 .Q:'$D(^AUPNVRAD(APCHSDFN,0))

 .S APCHSEDT=$P($P($G(^AUPNVRAD(APCHSDFN,12)),U,1),".")

 .D RADDSP

 Q

RADDSP ;

 S APCHS0=$P(^AUPNVRAD(APCHSDFN,0),U,1)

 S APCHSRTX=$P(^RAMIS(71,$P(APCHS0,U),0),U,1)

 S BSDXTMP=BSDXTMP_$$FILL^BSDX41(10-$L(BSDXTMP))_APCHSRTX

 I APCHSEDT]"",APCHSEDT'=9999999-APCHSIVD S BSDXTMP=BSDXTMP_"  ("_$$FMTE^XLFDT(APCHSEDT,5)_")"

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S BSDXTMP=""

 I $P(APCHS0,U,5)]"" S BSDXTMP=$$FILL^BSDX41(10)_"RESULT:  " S APCHSDCD=$P(APCHS0,U,5) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$S(APCHSDCD]"":APCHSDCD,1:"<none recorded>")_$C(30)

 I $P(APCHS0,U,6)]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="  "_"Diagnostic Code: "_$$VAL^XBDIQ1(9000010.22,APCHSDFN,.06)_$C(30)

 I $G(^AUPNVRAD(APCHSDFN,11))]"" S BSDXTMP=$$FILL^BSDX41(10)_"IMPRESSION:  " S APCHSICL=12,APCHSNRQ=$G(^AUPNVRAD(APCHSDFN,11)),APCHSTXT="",APCHSICD="" D PRTTXT^BSDX41F

 I $G(^AUPNVRAD(APCHSDFN,11))="" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 K APCHSTXT,APCHSNRQ

 Q

 ;

BSDX41P   ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 +1       ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

 +2       ;

RAD       ; ******************* RAD TESTS - ALL * 9000010.12 *******

 +1       ; <SETUP>

 +2        IF '$DATA(^AUPNVRAD("AA",APCHSPAT))

               QUIT 

 +3        KILL APCHSRRT

 +4        XECUTE APCHSBRK

 +5       ; <DISPLAY>

 +6        SET APCHST=""

           FOR APCHSQ=0:0

               SET APCHST=$ORDER(^AUPNVRAD("AA",APCHSPAT,APCHST))

               IF APCHST=""

                   QUIT 

               SET APCHSTX=$PIECE(^RAMIS(71,APCHST,0),U,1)

               SET APCHSTL=$LENGTH(APCHSTX)

               XECUTE APCHSCKP

               IF $DATA(APCHSQIT)

                   QUIT 

               DO RADBLD

 +7       ; <CLEANUP>

 +8       ;now display RAD refusals

 +9        SET APCHST="RADIOLOGY EXAM"

           SET APCHSFN=71

           DO DISPREF^BSDX41F

 +10       KILL APCHST,APCHSFN

RADX       KILL APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSRDG,APCHSVDF,APCHSDAT,X,Y

 +1        KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE

 +2        QUIT 

RADBLD     SET APCHSIVD=""

           FOR APCHSQ=0:0

               SET APCHSIVD=$ORDER(^AUPNVRAD("AA",APCHSPAT,APCHST,APCHSIVD))

               IF APCHSIVD=""!(APCHSIVD>APCHSDLM)

                   QUIT 

               DO RADBLD1

 +1        QUIT 

RADBLD1   ;S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y

 +1       ;X APCHSCKP Q:$D(APCHSQIT)

 +2        SET Y=-APCHSIVD\1+9999999

           XECUTE APCHSCVD

           SET APCHSDAT=Y

 +3        SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)

 +4        SET BSDXTMP=APCHSDAT

 +5        SET APCHSDFN=0

           FOR APCHSQ=0:0

               SET APCHSDFN=$ORDER(^AUPNVRAD("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN))

               IF 'APCHSDFN

                   QUIT 

               Begin DoDot:1

 +6                IF '$DATA(^AUPNVRAD(APCHSDFN,0))

                       QUIT 

 +7                SET APCHSEDT=$PIECE($PIECE($GET(^AUPNVRAD(APCHSDFN,12)),U,1),".")

 +8                DO RADDSP

               End DoDot:1

 +9        QUIT 

RADDSP    ;

 +1        SET APCHS0=$PIECE(^AUPNVRAD(APCHSDFN,0),U,1)

 +2        SET APCHSRTX=$PIECE(^RAMIS(71,$PIECE(APCHS0,U),0),U,1)

 +3        SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(10-$LENGTH(BSDXTMP))_APCHSRTX

 +4        IF APCHSEDT]""

               IF APCHSEDT'=9999999-APCHSIVD

                   SET BSDXTMP=BSDXTMP_"  ("_$$FMTE^XLFDT(APCHSEDT,5)_")"

 +5        SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)

 +6        SET BSDXTMP=""

 +7        IF $PIECE(APCHS0,U,5)]""

               SET BSDXTMP=$$FILL^BSDX41(10)_"RESULT:  "

               SET APCHSDCD=$PIECE(APCHS0,U,5)

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$SELECT(APCHSDCD]"":APCHSDCD,1:"<none recorded>")_$CHAR(30)

 +8        IF $PIECE(APCHS0,U,6)]""

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)="  "_"Diagnostic Code: "_$$VAL^XBDIQ1(9000010.22,APCHSDFN,.06)_$CHAR(30)

 +9        IF $GET(^AUPNVRAD(APCHSDFN,11))]""

               SET BSDXTMP=$$FILL^BSDX41(10)_"IMPRESSION:  "

               SET APCHSICL=12

               SET APCHSNRQ=$GET(^AUPNVRAD(APCHSDFN,11))

               SET APCHSTXT=""

               SET APCHSICD=""

               DO PRTTXT^BSDX41F

 +10       IF $GET(^AUPNVRAD(APCHSDFN,11))=""

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)

 +11       KILL APCHSTXT,APCHSNRQ

 +12       QUIT 

 +13      ;