- 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
