- PSAPROC5 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3**; 10/24/97
- ;This routine allows the user to edit invoices with errors or missing
- ;data.
- ;
- MANYUPCS ;List supply synonym data & ask user which on to use
- K PSADIFF,PSASAME
- S (PSACNT,PSAFND,PSAIEN50)=0,PSASUP=$P($P(PSADATA,"^",26),"~"),PSANDC="S"_PSASUP
- F S PSAIEN50=$O(^PSDRUG("C",PSANDC,PSAIEN50)) Q:'PSAIEN50 S PSASYN=0 D
- .F S PSASYN=$O(^PSDRUG("C",PSANDC,PSAIEN50,PSASYN)) Q:'PSASYN D
- ..Q:'$D(^PSDRUG(PSAIEN50,1,PSASYN,0))
- ..;DAVE B (PSA*3*3)
- ..Q:$D(^PSDRUG(PSAIEN50,"I"))
- ..I $P(^PSDRUG(PSAIEN50,1,PSASYN,0),"^",4)=PSAVSN S PSAFND=PSAFND+1,PSASAME(PSAFND)=PSAIEN50_"^"_PSASYN
- ..I $P(^PSDRUG(PSAIEN50,1,PSASYN,0),"^",4)'=PSAVSN S PSACNT=PSACNT+1,PSADIFF(PSACNT)=PSAIEN50_"^"_PSASYN
- G:PSAFND SAMEU G:PSACNT DIFFU
- Q
- ;
- SAMEU ;If more than one drug with same VSN, assign to correct drug.
- W !!,"There is more than one supply in the DRUG file",!,"with the same UPC and Vendor Stock Number.",!
- S (PSACNT,PSAMENU)=0
- F S PSACNT=$O(PSASAME(PSACNT)) Q:'PSACNT D
- .S PSAIEN50=$P(PSASAME(PSACNT),"^"),PSASYN=$P(PSASAME(PSACNT),"^",2),PSANODE=$G(^PSDRUG(PSAIEN50,1,PSASYN,0)),PSAMENU=PSAMENU+1
- .Q:'$D(^PSDRUG(PSAIEN50,1,PSASYN,0))
- .D LIST^PSAPROC4 Q:PSAOUT
- D CHOOSEU Q:PSAOUT
- I PSAPICK=PSAMENU D ASKDRUG^PSANDF G:PSAOUT KILL^PSAPROC4 S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",26)=PSASUP,PSANEXT=1,PSADATA=^(PSALINE) G KILL^PSAPROC4
- I PSAPICK<PSAMENU D
- .S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=PSANDC,$P(^(PSALINE),"^",7)=$P(PSASAME(PSAPICK),"^",2),$P(^(PSALINE),"^",15)=$P(PSASAME(PSAPICK),"^"),$P(^(PSALINE),"^",26)=PSASUP,PSANEXT=1,PSADATA=^(PSALINE)
- .I $P(^XTMP("PSAPV",PSACTRL,"IN"),"^",13)="SUP" S $P(^("IN"),"^",13)="",PSAIN=^XTMP("PSAPV",PSACTRL,"IN")
- G KILL^PSAPROC4
- ;
- DIFFU ;If more than one supply with different UPC, assign to correct drug.
- W !!,"There is more than one supply in the DRUG file with the same UPC.",!
- S (PSACNT,PSAMENU)=0 F S PSACNT=$O(PSADIFF(PSACNT)) Q:'PSACNT D
- .S PSAIEN50=$P(PSADIFF(PSACNT),"^"),PSASYN=$P(PSADIFF(PSACNT),"^",2),PSANODE=$G(^PSDRUG(PSAIEN50,1,PSASYN,0)),PSAMENU=PSAMENU+1
- .Q:'$D(^PSDRUG(PSAIEN50,1,PSASYN,0))
- .D LIST^PSAPROC4 Q:PSAOUT
- D CHOOSEU Q:PSAOUT
- I PSAPICK=PSAMENU D ASKDRUG^PSANDF G:PSAOUT KILL^PSAPROC4 S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",26)=PSASUP,PSANEXT=1,PSADATA=^(PSALINE) G KILL^PSAPROC4
- I PSAPICK<PSAMENU D
- .S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=PSANDC,$P(^(PSALINE),"^",7)=$P(PSADIFF(PSAPICK),"^",2),$P(^(PSALINE),"^",15)=$P(PSADIFF(PSAPICK),"^"),$P(^(PSALINE),"^",26)=PSASUP,PSANEXT=1,PSADATA=^(PSALINE)
- .I $P(^XTMP("PSAPV",PSACTRL,"IN"),"^",13)="SUP" S $P(^("IN"),"^",13)="",PSAIN=^XTMP("PSAPV",PSACTRL,"IN")
- G KILL^PSAPROC4
- ;
- CHOOSEU S PSAMENU=PSAMENU+1
- W !?1,PSAMENU_".",?4,"Select another item."
- W ! S DIR(0)="NO^1:"_PSAMENU,DIR("A")="Select the invoiced item",DIR("?")="Select the item from the list for which you were invoiced.",DIR("??")="^D UPCHELP^PSAPROC5"
- D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 Q
- S PSAPICK=+Y
- Q
- ;
- NDCDIFF ;If New NDC is correct, remove "~" piece with questionable NDC in ^XTMP.
- ;If Old NDC is correct, remove "~" piece with questionable NDC & set
- ;old NDC in NDC piece in ^XTMP.
- W !!,"There is a change in Vendor Stock Number's NDC."
- W !,"New NDC: "_PSANDC_" "
- W !,"Old NDC: "_$P($P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",5),"~",3),!
- S DIR(0)="Y",DIR("A")="Is the new NDC correct",DIR("B")="Y",DIR("?",1)="Enter Yes if the line item's NDC is correct.",DIR("?")="Enter No is the old NDC is correct."
- S DIR("??")="^D NEWOLDN^PSAPROC5" D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 Q
- I +Y S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",5)=PSAVSN_"~~~1",$P(^(PSALINE),"^",4)=PSANDC,PSADATA=^(PSALINE),PSANEXT=1 Q
- S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=$P($P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",5),"~",3),$P(^(PSALINE),"^",5)=PSAVSN,PSANEXT=1,PSADATA=^(PSALINE)
- Q
- ;
- SUPDIFF ;If New UPC is correct, remove "~" piece with questionable UPC in ^XTMP.
- ;If Old UPC is correct, remove "~" piece with questionable UPC & set old UPC in VSN piece in ^XTMP.
- W !!,"There is a change in item's Universal Product Code (UPC)."
- W !,"New UPC: "_PSAUPC
- W !,"Old UPC: "_$P($P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",26),"~",3),!
- S DIR(0)="Y",DIR("A")="Is the new UPC correct",DIR("B")="Y",DIR("?",1)="Enter Yes if the line item's Universal Product Code is correct.",DIR("?")="Enter No is the old Universal Product Code is correct."
- S DIR("??")="^D NEWUPC^PSAPROC5" D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 Q
- S PSANDC="S"_$P($P(PSADATA,"^",26),"~")
- I +Y S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=PSANDC,$P(^(PSALINE),"^",26)=PSAUPC,PSADATA=^(PSALINE),PSANEXT=1 Q
- S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",26)=$P($P(^(PSALINE),"^",26),"~",3),$P(^(PSALINE),"^",4)=PSANDC,PSADATA=^(PSALINE),PSANEXT=1
- Q
- ;
- VSNDIFF ;If New VSN is correct, remove "~" piece with questionable VSN in ^XTMP.
- ;If Old VSN is correct, remove "~" piece with questionable VSN & set old VSN in VSN piece in ^XTMP.
- W !!,"There is a change in the NDC's Vendor Stock Number (VSN)."
- W !,"New VSN: "_PSAVSN_" "
- W !,"Old VSN: "_$P($P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4),"~",3),!
- S DIR(0)="Y",DIR("A")="Is the new VSN correct",DIR("B")="Y",DIR("?",1)="Enter Yes if the line item's Vendor Stock Number is correct.",DIR("?")="Enter No is the old Vendor Stock Number is correct."
- S DIR("??")="^D NEWOLD^PSAPROC5" D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 Q
- I +Y S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=PSANDC_"~~~1",$P(^(PSALINE),"^",5)=PSAVSN,PSADATA=^(PSALINE),PSANEXT=1 Q
- S $P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",5)=$P($P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4),"~",3),$P(^(PSALINE),"^",4)=PSANDC,PSADATA=^(PSALINE),PSANEXT=1
- Q
- ;
- NEWOLD ;Extended help to 'Is new VSN correct'
- W !?5,"Enter Yes to add another synonym for the NDC with the new VSN.",!?5,"Enter No to discard the new VSN."
- Q
- NEWOLDN ;Extended help to 'Is new NDC correct'
- W !?5,"Enter Yes to add another synonym for the NDC with the new NDC.",!?5,"Enter No to discard the new NDC."
- Q
- NEWUPC ;Extended help to 'Is new UPC correct'
- W !?5,"Enter Yes to add another synonym for the NDC with the new UPC.",!?5,"Enter No to discard the new UPC."
- Q
- UPCHELP ;Extended help for selecting invoiced supply
- W !?5,"Enter the number of the invoiced item. If you select an item from the",!?5,"list, the invoice data will be added to that item. If you select to"
- W !?5,"add a new entry in the DRUG file for the invoiced item, a new",!?5,"synonym for the item will be added to the DRUG file."
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAPROC5 6736 printed Jan 18, 2025@02:51:22 Page 2
- PSAPROC5 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;7/23/97
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3**; 10/24/97
- +2 ;This routine allows the user to edit invoices with errors or missing
- +3 ;data.
- +4 ;
- MANYUPCS ;List supply synonym data & ask user which on to use
- +1 KILL PSADIFF,PSASAME
- +2 SET (PSACNT,PSAFND,PSAIEN50)=0
- SET PSASUP=$PIECE($PIECE(PSADATA,"^",26),"~")
- SET PSANDC="S"_PSASUP
- +3 FOR
- SET PSAIEN50=$ORDER(^PSDRUG("C",PSANDC,PSAIEN50))
- if 'PSAIEN50
- QUIT
- SET PSASYN=0
- Begin DoDot:1
- +4 FOR
- SET PSASYN=$ORDER(^PSDRUG("C",PSANDC,PSAIEN50,PSASYN))
- if 'PSASYN
- QUIT
- Begin DoDot:2
- +5 if '$DATA(^PSDRUG(PSAIEN50,1,PSASYN,0))
- QUIT
- +6 ;DAVE B (PSA*3*3)
- +7 if $DATA(^PSDRUG(PSAIEN50,"I"))
- QUIT
- +8 IF $PIECE(^PSDRUG(PSAIEN50,1,PSASYN,0),"^",4)=PSAVSN
- SET PSAFND=PSAFND+1
- SET PSASAME(PSAFND)=PSAIEN50_"^"_PSASYN
- +9 IF $PIECE(^PSDRUG(PSAIEN50,1,PSASYN,0),"^",4)'=PSAVSN
- SET PSACNT=PSACNT+1
- SET PSADIFF(PSACNT)=PSAIEN50_"^"_PSASYN
- End DoDot:2
- End DoDot:1
- +10 if PSAFND
- GOTO SAMEU
- if PSACNT
- GOTO DIFFU
- +11 QUIT
- +12 ;
- SAMEU ;If more than one drug with same VSN, assign to correct drug.
- +1 WRITE !!,"There is more than one supply in the DRUG file",!,"with the same UPC and Vendor Stock Number.",!
- +2 SET (PSACNT,PSAMENU)=0
- +3 FOR
- SET PSACNT=$ORDER(PSASAME(PSACNT))
- if 'PSACNT
- QUIT
- Begin DoDot:1
- +4 SET PSAIEN50=$PIECE(PSASAME(PSACNT),"^")
- SET PSASYN=$PIECE(PSASAME(PSACNT),"^",2)
- SET PSANODE=$GET(^PSDRUG(PSAIEN50,1,PSASYN,0))
- SET PSAMENU=PSAMENU+1
- +5 if '$DATA(^PSDRUG(PSAIEN50,1,PSASYN,0))
- QUIT
- +6 DO LIST^PSAPROC4
- if PSAOUT
- QUIT
- End DoDot:1
- +7 DO CHOOSEU
- if PSAOUT
- QUIT
- +8 IF PSAPICK=PSAMENU
- DO ASKDRUG^PSANDF
- if PSAOUT
- GOTO KILL^PSAPROC4
- SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",26)=PSASUP
- SET PSANEXT=1
- SET PSADATA=^(PSALINE)
- GOTO KILL^PSAPROC4
- +9 IF PSAPICK<PSAMENU
- Begin DoDot:1
- +10 SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=PSANDC
- SET $PIECE(^(PSALINE),"^",7)=$PIECE(PSASAME(PSAPICK),"^",2)
- SET $PIECE(^(PSALINE),"^",15)=$PIECE(PSASAME(PSAPICK),"^")
- SET $PIECE(^(PSALINE),"^",26)=PSASUP
- SET PSANEXT=1
- SET PSADATA=^(PSALINE)
- +11 IF $PIECE(^XTMP("PSAPV",PSACTRL,"IN"),"^",13)="SUP"
- SET $PIECE(^("IN"),"^",13)=""
- SET PSAIN=^XTMP("PSAPV",PSACTRL,"IN")
- End DoDot:1
- +12 GOTO KILL^PSAPROC4
- +13 ;
- DIFFU ;If more than one supply with different UPC, assign to correct drug.
- +1 WRITE !!,"There is more than one supply in the DRUG file with the same UPC.",!
- +2 SET (PSACNT,PSAMENU)=0
- FOR
- SET PSACNT=$ORDER(PSADIFF(PSACNT))
- if 'PSACNT
- QUIT
- Begin DoDot:1
- +3 SET PSAIEN50=$PIECE(PSADIFF(PSACNT),"^")
- SET PSASYN=$PIECE(PSADIFF(PSACNT),"^",2)
- SET PSANODE=$GET(^PSDRUG(PSAIEN50,1,PSASYN,0))
- SET PSAMENU=PSAMENU+1
- +4 if '$DATA(^PSDRUG(PSAIEN50,1,PSASYN,0))
- QUIT
- +5 DO LIST^PSAPROC4
- if PSAOUT
- QUIT
- End DoDot:1
- +6 DO CHOOSEU
- if PSAOUT
- QUIT
- +7 IF PSAPICK=PSAMENU
- DO ASKDRUG^PSANDF
- if PSAOUT
- GOTO KILL^PSAPROC4
- SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",26)=PSASUP
- SET PSANEXT=1
- SET PSADATA=^(PSALINE)
- GOTO KILL^PSAPROC4
- +8 IF PSAPICK<PSAMENU
- Begin DoDot:1
- +9 SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=PSANDC
- SET $PIECE(^(PSALINE),"^",7)=$PIECE(PSADIFF(PSAPICK),"^",2)
- SET $PIECE(^(PSALINE),"^",15)=$PIECE(PSADIFF(PSAPICK),"^")
- SET $PIECE(^(PSALINE),"^",26)=PSASUP
- SET PSANEXT=1
- SET PSADATA=^(PSALINE)
- +10 IF $PIECE(^XTMP("PSAPV",PSACTRL,"IN"),"^",13)="SUP"
- SET $PIECE(^("IN"),"^",13)=""
- SET PSAIN=^XTMP("PSAPV",PSACTRL,"IN")
- End DoDot:1
- +11 GOTO KILL^PSAPROC4
- +12 ;
- CHOOSEU SET PSAMENU=PSAMENU+1
- +1 WRITE !?1,PSAMENU_".",?4,"Select another item."
- +2 WRITE !
- SET DIR(0)="NO^1:"_PSAMENU
- SET DIR("A")="Select the invoiced item"
- SET DIR("?")="Select the item from the list for which you were invoiced."
- SET DIR("??")="^D UPCHELP^PSAPROC5"
- +3 DO ^DIR
- KILL DIR
- IF $GET(DIRUT)
- SET PSAOUT=1
- QUIT
- +4 SET PSAPICK=+Y
- +5 QUIT
- +6 ;
- NDCDIFF ;If New NDC is correct, remove "~" piece with questionable NDC in ^XTMP.
- +1 ;If Old NDC is correct, remove "~" piece with questionable NDC & set
- +2 ;old NDC in NDC piece in ^XTMP.
- +3 WRITE !!,"There is a change in Vendor Stock Number's NDC."
- +4 WRITE !,"New NDC: "_PSANDC_" "
- +5 WRITE !,"Old NDC: "_$PIECE($PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",5),"~",3),!
- +6 SET DIR(0)="Y"
- SET DIR("A")="Is the new NDC correct"
- SET DIR("B")="Y"
- SET DIR("?",1)="Enter Yes if the line item's NDC is correct."
- SET DIR("?")="Enter No is the old NDC is correct."
- +7 SET DIR("??")="^D NEWOLDN^PSAPROC5"
- DO ^DIR
- KILL DIR
- IF $GET(DIRUT)
- SET PSAOUT=1
- QUIT
- +8 IF +Y
- SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",5)=PSAVSN_"~~~1"
- SET $PIECE(^(PSALINE),"^",4)=PSANDC
- SET PSADATA=^(PSALINE)
- SET PSANEXT=1
- QUIT
- +9 SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=$PIECE($PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",5),"~",3)
- SET $PIECE(^(PSALINE),"^",5)=PSAVSN
- SET PSANEXT=1
- SET PSADATA=^(PSALINE)
- +10 QUIT
- +11 ;
- SUPDIFF ;If New UPC is correct, remove "~" piece with questionable UPC in ^XTMP.
- +1 ;If Old UPC is correct, remove "~" piece with questionable UPC & set old UPC in VSN piece in ^XTMP.
- +2 WRITE !!,"There is a change in item's Universal Product Code (UPC)."
- +3 WRITE !,"New UPC: "_PSAUPC
- +4 WRITE !,"Old UPC: "_$PIECE($PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",26),"~",3),!
- +5 SET DIR(0)="Y"
- SET DIR("A")="Is the new UPC correct"
- SET DIR("B")="Y"
- SET DIR("?",1)="Enter Yes if the line item's Universal Product Code is correct."
- SET DIR("?")="Enter No is the old Universal Product Code is correct."
- +6 SET DIR("??")="^D NEWUPC^PSAPROC5"
- DO ^DIR
- KILL DIR
- IF $GET(DIRUT)
- SET PSAOUT=1
- QUIT
- +7 SET PSANDC="S"_$PIECE($PIECE(PSADATA,"^",26),"~")
- +8 IF +Y
- SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=PSANDC
- SET $PIECE(^(PSALINE),"^",26)=PSAUPC
- SET PSADATA=^(PSALINE)
- SET PSANEXT=1
- QUIT
- +9 SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",26)=$PIECE($PIECE(^(PSALINE),"^",26),"~",3)
- SET $PIECE(^(PSALINE),"^",4)=PSANDC
- SET PSADATA=^(PSALINE)
- SET PSANEXT=1
- +10 QUIT
- +11 ;
- VSNDIFF ;If New VSN is correct, remove "~" piece with questionable VSN in ^XTMP.
- +1 ;If Old VSN is correct, remove "~" piece with questionable VSN & set old VSN in VSN piece in ^XTMP.
- +2 WRITE !!,"There is a change in the NDC's Vendor Stock Number (VSN)."
- +3 WRITE !,"New VSN: "_PSAVSN_" "
- +4 WRITE !,"Old VSN: "_$PIECE($PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4),"~",3),!
- +5 SET DIR(0)="Y"
- SET DIR("A")="Is the new VSN correct"
- SET DIR("B")="Y"
- SET DIR("?",1)="Enter Yes if the line item's Vendor Stock Number is correct."
- SET DIR("?")="Enter No is the old Vendor Stock Number is correct."
- +6 SET DIR("??")="^D NEWOLD^PSAPROC5"
- DO ^DIR
- KILL DIR
- IF $GET(DIRUT)
- SET PSAOUT=1
- QUIT
- +7 IF +Y
- SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4)=PSANDC_"~~~1"
- SET $PIECE(^(PSALINE),"^",5)=PSAVSN
- SET PSADATA=^(PSALINE)
- SET PSANEXT=1
- QUIT
- +8 SET $PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",5)=$PIECE($PIECE(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4),"~",3)
- SET $PIECE(^(PSALINE),"^",4)=PSANDC
- SET PSADATA=^(PSALINE)
- SET PSANEXT=1
- +9 QUIT
- +10 ;
- NEWOLD ;Extended help to 'Is new VSN correct'
- +1 WRITE !?5,"Enter Yes to add another synonym for the NDC with the new VSN.",!?5,"Enter No to discard the new VSN."
- +2 QUIT
- NEWOLDN ;Extended help to 'Is new NDC correct'
- +1 WRITE !?5,"Enter Yes to add another synonym for the NDC with the new NDC.",!?5,"Enter No to discard the new NDC."
- +2 QUIT
- NEWUPC ;Extended help to 'Is new UPC correct'
- +1 WRITE !?5,"Enter Yes to add another synonym for the NDC with the new UPC.",!?5,"Enter No to discard the new UPC."
- +2 QUIT
- UPCHELP ;Extended help for selecting invoiced supply
- +1 WRITE !?5,"Enter the number of the invoiced item. If you select an item from the",!?5,"list, the invoice data will be added to that item. If you select to"
- +2 WRITE !?5,"add a new entry in the DRUG file for the invoiced item, a new",!?5,"synonym for the item will be added to the DRUG file."
- +3 QUIT