- PSUAR1 ;BIR/PDW - Start AR/WS Extract ;11 AUG 1999
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
- ;;
- ;PSUDTDA - IEN FOR DATE
- ;PSUSDA - IEN FOR INPATIENT SITE
- ;PSUDRDA - IEN FOR DRUG
- ;PSUCDA - IEN FOR CATEGORY
- ;PSUDIV - IEN FOR DIVISION OR "NONE"
- ;
- ;DBIAs
- ; Reference to file #58.5 supported by DBIA 456
- ; Reference to file #58.1 supported by DBIA 2515
- ; Reference to file #59.4 supported by DBIA 2498
- ; Reference to file #44 supported by DBIA 2439
- ; Reference to file #40.8 supported by DBIA 2438
- ; Reference to file #59 supported by DBIA 1876
- ; Reference to file #59.7 supported by DBIA 2854
- ;
- EN ;EP MAIN ENTRY POINT
- ;
- K PSUTDSP,PSUTRET
- ;
- START ;Start date scan thru stats file
- S PSUSDT=PSUSDT-.1
- S PSUDT=PSUSDT
- S PSUEDT=PSUEDT\1+.24
- Q F S PSUDT=$O(^PSI(58.5,"B",PSUDT)) Q:'PSUDT Q:PSUDT>PSUEDT D DATE Q:$G(PSUQUIT)
- Q
- DATE ;PROCESS ONE DATE - Loop through inpatient sites
- S PSUDTDA=$O(^PSI(58.5,"B",PSUDT,0))
- K PSUSITE
- D GETM^PSUTL(58.5,PSUDTDA,"1*^.01","PSUSITE")
- S PSUSDA=0
- F S PSUSDA=$O(PSUSITE(PSUSDA)) Q:PSUSDA'>0 D SITE Q:$G(PSUQUIT)
- K PSUSITE
- Q
- ;
- SITE ;Process one site for one date
- ; Find division for site for loading drug stats
- S PSUDIV=$$DIV(PSUSDA,PSUDTDA)
- ;
- I PSUDIV="NULL" S PSUDIV=PSUSNDR
- ;
- ; Process individual Drug information from 58.52
- ; Drug multiple loaded into PSUDRUG
- K PSUDRUG
- D GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","2*^.01","PSUDRUG")
- S PSUDRDA=0
- F S PSUDRDA=$O(PSUDRUG(PSUDRDA)) Q:PSUDRDA'>0 D DRUG Q:$G(PSUQUIT)
- K PSUDRUG
- ;
- D MAP
- ; Process Amis categories from 58.501
- ; Category multiple loaded into PSUCAT
- K PSUCAT
- CATEGORY ;EP Pull Categories
- K PSUAMCAT
- D GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","1*^.01;1;2;3;4","PSUAMCAT","I")
- ;
- ; Move (da,Fld,"I") values to (da,Fld) nodes
- D MOVEMI^PSUTL("PSUAMCAT")
- ;
- ; Gather totals for categories and accumulate in
- ; ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP":COST")
- N PSUDISP,PSUCOST
- S PSUCDA=0 F S PSUCDA=$O(PSUAMCAT(PSUCDA)) Q:PSUCDA'>0 D
- . S PSUDISP=PSUAMCAT(PSUCDA,1)-PSUAMCAT(PSUCDA,3)
- . S PSUCOST=PSUAMCAT(PSUCDA,2)-PSUAMCAT(PSUCDA,4)
- . S PSUAMCAT=PSUAMCAT(PSUCDA,.01) ; "03"-"04"-"06" etc
- . S X=$G(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP"))
- . S ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP")=X+PSUDISP
- . S X=$G(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST"))
- . S ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")=X+PSUCOST
- . M ^XTMP("PSUTCST",PSUDIV,PSUAMCAT)=^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")
- ;
- Q
- ;
- DRUG ; Process one drug for one site for one day
- ; Load & loop categories within Drug
- ; total dispense & returns
- ; Category multiple loaded into PSUCAT
- ;
- S PSUDRIEN=$$VALI^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA",.01)
- K PSUCAT
- D GETM^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA","1*^.01;1","PSUCAT","I")
- ;
- S PSUCDA=0,PSUDISP=0,PSUTR=0
- F S PSUCDA=$O(PSUCAT(PSUCDA)) Q:PSUCDA'>0 Q:$G(PSUQUIT) D
- . S X=PSUCAT(PSUCDA,.01,"I")
- . S Y=PSUCAT(PSUCDA,1,"I")
- . I (X="A")!(X="W") S PSUDISP=PSUDISP+Y,PSUTDS=PSUDISP
- . I (X="RA")!(X="RW") S PSUDISP=PSUDISP-Y,PSUTR=PSUTR+Y
- ; Adjust accumulative dispenses
- ;
- S X=$G(^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN))
- S ^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN)=X+PSUDISP
- ;
- N PSUT
- S PSUT=$G(PSUTDSP(PSUDIV,PSUDRIEN))
- I $D(PSUTDS) D
- .S PSUTDSP(PSUDIV,PSUDRIEN)=PSUTDS+PSUT ;Total Quantity dispensed
- .I (PSUTDS+PSUT)=0 S PSUTDSP(PSUDIV,PSUDRIEN)=""
- ;
- N PSUT1
- S PSUT1=$G(PSUTRET(PSUDIV,PSUDRIEN))
- I $D(PSUTR) D
- .S PSUTRET(PSUDIV,PSUDRIEN)=PSUTR+PSUT1 ;Total Quantity returned
- .I (PSUTR+PSUT1)=0 S PSUTRET(PSUDIV,PSUDRIEN)=""
- K PSUCAT
- Q
- DIV(PSUSDA,PSUDTDA) ;EP process for a site the associated divisions by date.
- ; uses PSUSDA as entry for site ien in file 59.4 : returns division
- ; as of 2/99 date is no longer used as a parameter
- N PSUDIV,PSUDT
- I '$D(^XTMP(PSUARSUB,"DIVLK",PSUSDA)) D AOU
- ; ^XTMP(PSUARSUB,"DIVlk",Site IEN, AOU Inactive Date -1)=Division IEN
- ;
- ; if AOU did not set division then return null
- I '$D(^XTMP(PSUARSUB,"DIVLK",PSUSDA)) S PSUDIV="NULL" Q PSUDIV
- ;
- S PSUDIV=$O(^XTMP(PSUARSUB,"DIVLK",PSUSDA,""))
- Q PSUDIV
- ;
- AOU ;EP map divisions by dates for inpatient sites from the AOU file
- ;PSUADA - ien for AOU Stock file
- ;
- N PSUADA,PSUDIV,PSUINACT,PSUDIV,PSUSLOC,MAPLOCI
- ;
- D GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI","I")
- ;set array MAPLOCI(ien,fld)=internal value
- ;field .02 points to 40.8 Medical Center Division where fac num is #1
- ;field .03 points to 59 Outpatient site where site num is #.06
- D MOVEMI^PSUTL("MAPLOCI")
- ;
- K ^XTMP(PSUARSUB,"DIVLK")
- ;
- S PSUADA=0
- F S PSUADA=$O(^PSI(58.1,"ASITE",PSUSDA,PSUADA)) Q:PSUADA'>0 D
- . N PSUDIV S PSUDIV=""
- . S PSUSLOC=$$VALI^PSUTL(59.4,PSUSDA,.01)
- . S PSUINACT=$$VALI^PSUTL(58.1,PSUADA,3)
- . I PSUINACT Q ; inactivated sites are to be ignored regardles of date
- . S:'PSUINACT PSUINACT=DT+1
- . I '$G(MAPLOCI(PSUADA,.01)) S PSUDIV="NULL"
- . I $G(MAPLOCI(PSUADA,.01)) D
- .. S X=$G(MAPLOCI(PSUADA,.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1)
- .. S X=$G(MAPLOCI(PSUADA,.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06)
- .. S ^XTMP(PSUARSUB,"DIVLK",PSUSDA,PSUDIV)=""
- ;
- Q
- ;
- MAP ;Find out whether an Area of Use (AOU) is mapped to a division or
- ;outpatient site. If it is not mapped, store the NAME and INACTIVATION
- ;DATE (if applicable) in a global to be mailed to the user.
- ;
- S PSUNAM=0 ;This is the name of the Area of USE
- ;
- F S PSUNAM=$O(^PSI(58.1,"B",PSUNAM)) Q:PSUNAM="" D
- .S IEN=0 ;This is the IEN for file 58.1
- .F S IEN=$O(^PSI(58.1,"B",PSUNAM,IEN)) Q:IEN="" D
- ..K AOU
- ..D GETS^PSUTL(58.1,IEN,".01;3","AOU(IEN)") ;Name & Inactive Date
- ..D MAP1
- Q
- ;
- MAP1 ;MAP continued. This subroutine takes the IEN from file 58.1 and looks
- ;to see if it is in file 59.7, field 90.01. If it is, then it has
- ;been mapped if there is a value in subfield .02 or .03.
- ;If there is no value in subfield .02 or .03 it has not been mapped
- ;
- ;Keep only the entries that are NOT mapped
- ;
- N PSUDA
- ;
- I $G(^PS(59.7,1,90.01,IEN,0)) D
- .D GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI")
- .S PSUDA=0
- .F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D
- ..I MAPLOCI(PSUDA,.02)'="" K AOU(PSUDA)
- ..I $G(MAPLOCI(PSUDA,.03))'="" K AOU(PSUDA)
- M ^XTMP(PSUARSUB,"AOU")=AOU ;Contains only unmapped locations
- Q
- ;
- CLEAR ;EP Clear ^XTMP("PSUAR*")
- S X="PSUAR",Y=X
- F S Y=$O(^XTMP(Y)) Q:($E(Y,1,5)'=X) W !,Y K ^XTMP(Y)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUAR1 6612 printed Feb 18, 2025@23:53:24 Page 2
- PSUAR1 ;BIR/PDW - Start AR/WS Extract ;11 AUG 1999
- +1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
- +2 ;;
- +3 ;PSUDTDA - IEN FOR DATE
- +4 ;PSUSDA - IEN FOR INPATIENT SITE
- +5 ;PSUDRDA - IEN FOR DRUG
- +6 ;PSUCDA - IEN FOR CATEGORY
- +7 ;PSUDIV - IEN FOR DIVISION OR "NONE"
- +8 ;
- +9 ;DBIAs
- +10 ; Reference to file #58.5 supported by DBIA 456
- +11 ; Reference to file #58.1 supported by DBIA 2515
- +12 ; Reference to file #59.4 supported by DBIA 2498
- +13 ; Reference to file #44 supported by DBIA 2439
- +14 ; Reference to file #40.8 supported by DBIA 2438
- +15 ; Reference to file #59 supported by DBIA 1876
- +16 ; Reference to file #59.7 supported by DBIA 2854
- +17 ;
- EN ;EP MAIN ENTRY POINT
- +1 ;
- +2 KILL PSUTDSP,PSUTRET
- +3 ;
- START ;Start date scan thru stats file
- +1 SET PSUSDT=PSUSDT-.1
- +2 SET PSUDT=PSUSDT
- +3 SET PSUEDT=PSUEDT\1+.24
- Q FOR
- SET PSUDT=$ORDER(^PSI(58.5,"B",PSUDT))
- if 'PSUDT
- QUIT
- if PSUDT>PSUEDT
- QUIT
- DO DATE
- if $GET(PSUQUIT)
- QUIT
- +1 QUIT
- DATE ;PROCESS ONE DATE - Loop through inpatient sites
- +1 SET PSUDTDA=$ORDER(^PSI(58.5,"B",PSUDT,0))
- +2 KILL PSUSITE
- +3 DO GETM^PSUTL(58.5,PSUDTDA,"1*^.01","PSUSITE")
- +4 SET PSUSDA=0
- +5 FOR
- SET PSUSDA=$ORDER(PSUSITE(PSUSDA))
- if PSUSDA'>0
- QUIT
- DO SITE
- if $GET(PSUQUIT)
- QUIT
- +6 KILL PSUSITE
- +7 QUIT
- +8 ;
- SITE ;Process one site for one date
- +1 ; Find division for site for loading drug stats
- +2 SET PSUDIV=$$DIV(PSUSDA,PSUDTDA)
- +3 ;
- +4 IF PSUDIV="NULL"
- SET PSUDIV=PSUSNDR
- +5 ;
- +6 ; Process individual Drug information from 58.52
- +7 ; Drug multiple loaded into PSUDRUG
- +8 KILL PSUDRUG
- +9 DO GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","2*^.01","PSUDRUG")
- +10 SET PSUDRDA=0
- +11 FOR
- SET PSUDRDA=$ORDER(PSUDRUG(PSUDRDA))
- if PSUDRDA'>0
- QUIT
- DO DRUG
- if $GET(PSUQUIT)
- QUIT
- +12 KILL PSUDRUG
- +13 ;
- +14 DO MAP
- +15 ; Process Amis categories from 58.501
- +16 ; Category multiple loaded into PSUCAT
- +17 KILL PSUCAT
- CATEGORY ;EP Pull Categories
- +1 KILL PSUAMCAT
- +2 DO GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","1*^.01;1;2;3;4","PSUAMCAT","I")
- +3 ;
- +4 ; Move (da,Fld,"I") values to (da,Fld) nodes
- +5 DO MOVEMI^PSUTL("PSUAMCAT")
- +6 ;
- +7 ; Gather totals for categories and accumulate in
- +8 ; ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP":COST")
- +9 NEW PSUDISP,PSUCOST
- +10 SET PSUCDA=0
- FOR
- SET PSUCDA=$ORDER(PSUAMCAT(PSUCDA))
- if PSUCDA'>0
- QUIT
- Begin DoDot:1
- +11 SET PSUDISP=PSUAMCAT(PSUCDA,1)-PSUAMCAT(PSUCDA,3)
- +12 SET PSUCOST=PSUAMCAT(PSUCDA,2)-PSUAMCAT(PSUCDA,4)
- +13 ; "03"-"04"-"06" etc
- SET PSUAMCAT=PSUAMCAT(PSUCDA,.01)
- +14 SET X=$GET(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP"))
- +15 SET ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP")=X+PSUDISP
- +16 SET X=$GET(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST"))
- +17 SET ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")=X+PSUCOST
- +18 MERGE ^XTMP("PSUTCST",PSUDIV,PSUAMCAT)=^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")
- End DoDot:1
- +19 ;
- +20 QUIT
- +21 ;
- DRUG ; Process one drug for one site for one day
- +1 ; Load & loop categories within Drug
- +2 ; total dispense & returns
- +3 ; Category multiple loaded into PSUCAT
- +4 ;
- +5 SET PSUDRIEN=$$VALI^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA",.01)
- +6 KILL PSUCAT
- +7 DO GETM^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA","1*^.01;1","PSUCAT","I")
- +8 ;
- +9 SET PSUCDA=0
- SET PSUDISP=0
- SET PSUTR=0
- +10 FOR
- SET PSUCDA=$ORDER(PSUCAT(PSUCDA))
- if PSUCDA'>0
- QUIT
- if $GET(PSUQUIT)
- QUIT
- Begin DoDot:1
- +11 SET X=PSUCAT(PSUCDA,.01,"I")
- +12 SET Y=PSUCAT(PSUCDA,1,"I")
- +13 IF (X="A")!(X="W")
- SET PSUDISP=PSUDISP+Y
- SET PSUTDS=PSUDISP
- +14 IF (X="RA")!(X="RW")
- SET PSUDISP=PSUDISP-Y
- SET PSUTR=PSUTR+Y
- End DoDot:1
- +15 ; Adjust accumulative dispenses
- +16 ;
- +17 SET X=$GET(^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN))
- +18 SET ^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN)=X+PSUDISP
- +19 ;
- +20 NEW PSUT
- +21 SET PSUT=$GET(PSUTDSP(PSUDIV,PSUDRIEN))
- +22 IF $DATA(PSUTDS)
- Begin DoDot:1
- +23 ;Total Quantity dispensed
- SET PSUTDSP(PSUDIV,PSUDRIEN)=PSUTDS+PSUT
- +24 IF (PSUTDS+PSUT)=0
- SET PSUTDSP(PSUDIV,PSUDRIEN)=""
- End DoDot:1
- +25 ;
- +26 NEW PSUT1
- +27 SET PSUT1=$GET(PSUTRET(PSUDIV,PSUDRIEN))
- +28 IF $DATA(PSUTR)
- Begin DoDot:1
- +29 ;Total Quantity returned
- SET PSUTRET(PSUDIV,PSUDRIEN)=PSUTR+PSUT1
- +30 IF (PSUTR+PSUT1)=0
- SET PSUTRET(PSUDIV,PSUDRIEN)=""
- End DoDot:1
- +31 KILL PSUCAT
- +32 QUIT
- DIV(PSUSDA,PSUDTDA) ;EP process for a site the associated divisions by date.
- +1 ; uses PSUSDA as entry for site ien in file 59.4 : returns division
- +2 ; as of 2/99 date is no longer used as a parameter
- +3 NEW PSUDIV,PSUDT
- +4 IF '$DATA(^XTMP(PSUARSUB,"DIVLK",PSUSDA))
- DO AOU
- +5 ; ^XTMP(PSUARSUB,"DIVlk",Site IEN, AOU Inactive Date -1)=Division IEN
- +6 ;
- +7 ; if AOU did not set division then return null
- +8 IF '$DATA(^XTMP(PSUARSUB,"DIVLK",PSUSDA))
- SET PSUDIV="NULL"
- QUIT PSUDIV
- +9 ;
- +10 SET PSUDIV=$ORDER(^XTMP(PSUARSUB,"DIVLK",PSUSDA,""))
- +11 QUIT PSUDIV
- +12 ;
- AOU ;EP map divisions by dates for inpatient sites from the AOU file
- +1 ;PSUADA - ien for AOU Stock file
- +2 ;
- +3 NEW PSUADA,PSUDIV,PSUINACT,PSUDIV,PSUSLOC,MAPLOCI
- +4 ;
- +5 DO GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI","I")
- +6 ;set array MAPLOCI(ien,fld)=internal value
- +7 ;field .02 points to 40.8 Medical Center Division where fac num is #1
- +8 ;field .03 points to 59 Outpatient site where site num is #.06
- +9 DO MOVEMI^PSUTL("MAPLOCI")
- +10 ;
- +11 KILL ^XTMP(PSUARSUB,"DIVLK")
- +12 ;
- +13 SET PSUADA=0
- +14 FOR
- SET PSUADA=$ORDER(^PSI(58.1,"ASITE",PSUSDA,PSUADA))
- if PSUADA'>0
- QUIT
- Begin DoDot:1
- +15 NEW PSUDIV
- SET PSUDIV=""
- +16 SET PSUSLOC=$$VALI^PSUTL(59.4,PSUSDA,.01)
- +17 SET PSUINACT=$$VALI^PSUTL(58.1,PSUADA,3)
- +18 ; inactivated sites are to be ignored regardles of date
- IF PSUINACT
- QUIT
- +19 if 'PSUINACT
- SET PSUINACT=DT+1
- +20 IF '$GET(MAPLOCI(PSUADA,.01))
- SET PSUDIV="NULL"
- +21 IF $GET(MAPLOCI(PSUADA,.01))
- Begin DoDot:2
- +22 SET X=$GET(MAPLOCI(PSUADA,.02))
- IF X
- SET PSUDIV=$$VALI^PSUTL(40.8,X,1)
- +23 SET X=$GET(MAPLOCI(PSUADA,.03))
- IF X
- SET PSUDIV=$$VALI^PSUTL(59,X,.06)
- +24 SET ^XTMP(PSUARSUB,"DIVLK",PSUSDA,PSUDIV)=""
- End DoDot:2
- End DoDot:1
- +25 ;
- +26 QUIT
- +27 ;
- MAP ;Find out whether an Area of Use (AOU) is mapped to a division or
- +1 ;outpatient site. If it is not mapped, store the NAME and INACTIVATION
- +2 ;DATE (if applicable) in a global to be mailed to the user.
- +3 ;
- +4 ;This is the name of the Area of USE
- SET PSUNAM=0
- +5 ;
- +6 FOR
- SET PSUNAM=$ORDER(^PSI(58.1,"B",PSUNAM))
- if PSUNAM=""
- QUIT
- Begin DoDot:1
- +7 ;This is the IEN for file 58.1
- SET IEN=0
- +8 FOR
- SET IEN=$ORDER(^PSI(58.1,"B",PSUNAM,IEN))
- if IEN=""
- QUIT
- Begin DoDot:2
- +9 KILL AOU
- +10 ;Name & Inactive Date
- DO GETS^PSUTL(58.1,IEN,".01;3","AOU(IEN)")
- +11 DO MAP1
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
- MAP1 ;MAP continued. This subroutine takes the IEN from file 58.1 and looks
- +1 ;to see if it is in file 59.7, field 90.01. If it is, then it has
- +2 ;been mapped if there is a value in subfield .02 or .03.
- +3 ;If there is no value in subfield .02 or .03 it has not been mapped
- +4 ;
- +5 ;Keep only the entries that are NOT mapped
- +6 ;
- +7 NEW PSUDA
- +8 ;
- +9 IF $GET(^PS(59.7,1,90.01,IEN,0))
- Begin DoDot:1
- +10 DO GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI")
- +11 SET PSUDA=0
- +12 FOR
- SET PSUDA=$ORDER(MAPLOCI(PSUDA))
- if PSUDA=""
- QUIT
- Begin DoDot:2
- +13 IF MAPLOCI(PSUDA,.02)'=""
- KILL AOU(PSUDA)
- +14 IF $GET(MAPLOCI(PSUDA,.03))'=""
- KILL AOU(PSUDA)
- End DoDot:2
- End DoDot:1
- +15 ;Contains only unmapped locations
- MERGE ^XTMP(PSUARSUB,"AOU")=AOU
- +16 QUIT
- +17 ;
- CLEAR ;EP Clear ^XTMP("PSUAR*")
- +1 SET X="PSUAR"
- SET Y=X
- +2 FOR
- SET Y=$ORDER(^XTMP(Y))
- if ($EXTRACT(Y,1,5)'=X)
- QUIT
- WRITE !,Y
- KILL ^XTMP(Y)
- +3 QUIT