- PSO126IX ;BIR/PDW-Execute CMOP INDICATOR Index ;08/12/2002
- ;;7.0;OUTPATIENT PHARMACY;**126**;DEC 1997
- Q
- CMPNDX ; new compound index on CMOP Indicator "CMP"
- ;check "A_x" indexes to CMP index
- W !,"Updating the RX Suspense file's new 'CMP' index."
- W !,"Processing the AQ, AL, AX, AP indexes into the CMP index"
- F NDX="Q","L","X","P" D
- . S INDX="A"_NDX W !!,INDX
- . S SDT=0 F S SDT=$O(^PS(52.5,INDX,SDT)) Q:'SDT D
- .. S DFN=0 F S DFN=$O(^PS(52.5,INDX,SDT,DFN)) Q:'DFN D
- ... S REC=0 F S REC=$O(^PS(52.5,INDX,SDT,DFN,REC)) Q:'REC D
- .... S F=$G(^PS(52.5,REC,0))
- .... I 'F K ^PS(52.5,INDX,SDT,DFN,REC) Q ;bad index
- .... S TYP=$$CMPRXTYP^PSOCMOP(REC),CNT=$G(CNT)+1 I '(CNT#100) W "."
- .... F VP="RX^1","SDT0^2","DFN0^3","DIV^6","STAT^7" D PIECE(F,U,VP)
- .... I NDX=STAT,DFN=DFN0,SDT=SDT0
- .... E K ^PS(52.5,INDX,SDT,DFN,REC)
- .... I STAT'="",$D(^PS(52.5,"CMP",STAT,TYP,DIV,SDT0,DFN,REC)) S ^PS(52.5,"CMP",NDX,TYP,DIV,SDT,DFN,REC)=""
- Q
- PIECE(REC,DLM,VP) ; VP="Variable^Piece" : S Variable=$P(REC,DLM,Piece)
- N V,P S V=$P(VP,DLM),P=$P(VP,DLM,2),@V=$P(REC,DLM,P)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO126IX 1100 printed Apr 23, 2025@18:37:02 Page 2
- PSO126IX ;BIR/PDW-Execute CMOP INDICATOR Index ;08/12/2002
- +1 ;;7.0;OUTPATIENT PHARMACY;**126**;DEC 1997
- +2 QUIT
- CMPNDX ; new compound index on CMOP Indicator "CMP"
- +1 ;check "A_x" indexes to CMP index
- +2 WRITE !,"Updating the RX Suspense file's new 'CMP' index."
- +3 WRITE !,"Processing the AQ, AL, AX, AP indexes into the CMP index"
- +4 FOR NDX="Q","L","X","P"
- Begin DoDot:1
- +5 SET INDX="A"_NDX
- WRITE !!,INDX
- +6 SET SDT=0
- FOR
- SET SDT=$ORDER(^PS(52.5,INDX,SDT))
- if 'SDT
- QUIT
- Begin DoDot:2
- +7 SET DFN=0
- FOR
- SET DFN=$ORDER(^PS(52.5,INDX,SDT,DFN))
- if 'DFN
- QUIT
- Begin DoDot:3
- +8 SET REC=0
- FOR
- SET REC=$ORDER(^PS(52.5,INDX,SDT,DFN,REC))
- if 'REC
- QUIT
- Begin DoDot:4
- +9 SET F=$GET(^PS(52.5,REC,0))
- +10 ;bad index
- IF 'F
- KILL ^PS(52.5,INDX,SDT,DFN,REC)
- QUIT
- +11 SET TYP=$$CMPRXTYP^PSOCMOP(REC)
- SET CNT=$GET(CNT)+1
- IF '(CNT#100)
- WRITE "."
- +12 FOR VP="RX^1","SDT0^2","DFN0^3","DIV^6","STAT^7"
- DO PIECE(F,U,VP)
- +13 IF NDX=STAT
- IF DFN=DFN0
- IF SDT=SDT0
- +14 IF '$TEST
- KILL ^PS(52.5,INDX,SDT,DFN,REC)
- +15 IF STAT'=""
- IF $DATA(^PS(52.5,"CMP",STAT,TYP,DIV,SDT0,DFN,REC))
- SET ^PS(52.5,"CMP",NDX,TYP,DIV,SDT,DFN,REC)=""
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 QUIT
- PIECE(REC,DLM,VP) ; VP="Variable^Piece" : S Variable=$P(REC,DLM,Piece)
- +1 NEW V,P
- SET V=$PIECE(VP,DLM)
- SET P=$PIECE(VP,DLM,2)
- SET @V=$PIECE(REC,DLM,P)
- +2 QUIT
