PSNPSS.m

PSNPSS ;BIR/WRT-kills off orderable item ; 04/18/01 14:58

 ;;4.0; NATIONAL DRUG FILE;**33,51**; 30 Oct 98

 ;References to ^PSDRUG supported by DBIAs #221 and #2352

 ;Reference to ^PS(50.606 supported by DBIA #2174

 ;Reference to ^PS(50.7 supported by DBIA #2180

 ;Reference to ^PS(52.6 supported by DBIA #1231

 ;Reference to ^PS(52.7 supported by DBIA #2173

BEGIN D DISP,SOL,ADD K ADDITM,BBC,DA,DFM,DIE,DOS,IVDF,IVDFPTR,OIDF,PSNOI,SOLITM,ADDNM,K,X,SOLNM

 Q

DISP S X=$$PSJDF^PSNAPIS(DA,K) I X]"" S DFM=$P(X,"^") I $D(^PSDRUG(PSNB,2)),$P(^PSDRUG(PSNB,2),"^",1)]"" S PSNOI=$P(^PSDRUG(PSNB,2),"^",1),OIDF=$P(^PS(50.7,PSNOI,0),"^",2) I DFM'=OIDF D KILLOI

 Q

KILLOI S ^TMP("PSNDP",$J,$P(^PSDRUG(PSNB,0),"^",1))="",DA=PSNB,DIE="^PSDRUG(",DR="2.1///"_"@" D ^DIE

 Q

SOL I $D(^PS(52.7,"AC",PSNB)) F BBC=0:0 S BBC=$O(^PS(52.7,"AC",PSNB,BBC)) Q:'BBC  S SOLITM=$P(^PS(52.7,BBC,0),"^",11) I SOLITM]"" I $D(^PS(52.7,"AOI",SOLITM,BBC)) D SOLCK

 Q

SOLCK S IVDFPTR=$P(^PS(50.7,SOLITM,0),"^",2),IVDF=$P(^PS(50.606,IVDFPTR,0),"^",1) I IVDF'=DFM,$P(^PS(52.7,BBC,0),"^",11)]"" S SOLNM=$P(^PS(52.7,BBC,0),"^",1),^TMP("PSNSL",$J,SOLNM)="" S DA=BBC,DIE="^PS(52.7,",DR="9///"_"@" D ^DIE

 Q

ADD I $D(^PS(52.6,"AC",PSNB)) F BBC=0:0 S BBC=$O(^PS(52.6,"AC",PSNB,BBC)) Q:'BBC  S ADDITM=$P(^PS(52.6,BBC,0),"^",11) I ADDITM]"" I $D(^PS(52.6,"AOI",ADDITM,BBC)) D ADDCK

 Q

ADDCK S IVDFPTR=$P(^PS(50.7,ADDITM,0),"^",2),IVDF=$P(^PS(50.606,IVDFPTR,0),"^",1) I IVDF'=DFM,$P(^PS(52.6,BBC,0),"^",11)]"" S ADDNM=$P(^PS(52.6,BBC,0),"^",1),^TMP("PSNAD",$J,ADDNM)="" S DA=BBC,DIE="^PS(52.6,",DR="15///"_"@" D ^DIE

 Q

PSNPSS    ;BIR/WRT-kills off orderable item ; 04/18/01 14:58

 +1       ;;4.0; NATIONAL DRUG FILE;**33,51**; 30 Oct 98

 +2       ;References to ^PSDRUG supported by DBIAs #221 and #2352

 +3       ;Reference to ^PS(50.606 supported by DBIA #2174

 +4       ;Reference to ^PS(50.7 supported by DBIA #2180

 +5       ;Reference to ^PS(52.6 supported by DBIA #1231

 +6       ;Reference to ^PS(52.7 supported by DBIA #2173

BEGIN      DO DISP

           DO SOL

           DO ADD

           KILL ADDITM,BBC,DA,DFM,DIE,DOS,IVDF,IVDFPTR,OIDF,PSNOI,SOLITM,ADDNM,K,X,SOLNM

 +1        QUIT 

DISP       SET X=$$PSJDF^PSNAPIS(DA,K)

           IF X]""

               SET DFM=$PIECE(X,"^")

               IF $DATA(^PSDRUG(PSNB,2))

                   IF $PIECE(^PSDRUG(PSNB,2),"^",1)]""

                       SET PSNOI=$PIECE(^PSDRUG(PSNB,2),"^",1)

                       SET OIDF=$PIECE(^PS(50.7,PSNOI,0),"^",2)

                       IF DFM'=OIDF

                           DO KILLOI

 +1        QUIT 

KILLOI     SET ^TMP("PSNDP",$JOB,$PIECE(^PSDRUG(PSNB,0),"^",1))=""

           SET DA=PSNB

           SET DIE="^PSDRUG("

           SET DR="2.1///"_"@"

           DO ^DIE

 +1        QUIT 

SOL        IF $DATA(^PS(52.7,"AC",PSNB))

               FOR BBC=0:0

                   SET BBC=$ORDER(^PS(52.7,"AC",PSNB,BBC))

                   IF 'BBC

                       QUIT 

                   SET SOLITM=$PIECE(^PS(52.7,BBC,0),"^",11)

                   IF SOLITM]""

                       IF $DATA(^PS(52.7,"AOI",SOLITM,BBC))

                           DO SOLCK

 +1        QUIT 

SOLCK      SET IVDFPTR=$PIECE(^PS(50.7,SOLITM,0),"^",2)

           SET IVDF=$PIECE(^PS(50.606,IVDFPTR,0),"^",1)

           IF IVDF'=DFM

               IF $PIECE(^PS(52.7,BBC,0),"^",11)]""

                   SET SOLNM=$PIECE(^PS(52.7,BBC,0),"^",1)

                   SET ^TMP("PSNSL",$JOB,SOLNM)=""

                   SET DA=BBC

                   SET DIE="^PS(52.7,"

                   SET DR="9///"_"@"

                   DO ^DIE

 +1        QUIT 

ADD        IF $DATA(^PS(52.6,"AC",PSNB))

               FOR BBC=0:0

                   SET BBC=$ORDER(^PS(52.6,"AC",PSNB,BBC))

                   IF 'BBC

                       QUIT 

                   SET ADDITM=$PIECE(^PS(52.6,BBC,0),"^",11)

                   IF ADDITM]""

                       IF $DATA(^PS(52.6,"AOI",ADDITM,BBC))

                           DO ADDCK

 +1        QUIT 

ADDCK      SET IVDFPTR=$PIECE(^PS(50.7,ADDITM,0),"^",2)

           SET IVDF=$PIECE(^PS(50.606,IVDFPTR,0),"^",1)

           IF IVDF'=DFM

               IF $PIECE(^PS(52.6,BBC,0),"^",11)]""

                   SET ADDNM=$PIECE(^PS(52.6,BBC,0),"^",1)

                   SET ^TMP("PSNAD",$JOB,ADDNM)=""

                   SET DA=BBC

                   SET DIE="^PS(52.6,"

                   SET DR="15///"_"@"

                   DO ^DIE

 +1        QUIT